home *** CD-ROM | disk | FTP | other *** search
/ Internet Info 1993 / Internet Info CD-ROM (Walnut Creek) (1993).iso / networking / terms / kermit / d / h100ker.f77 < prev    next >
Encoding:
Text File  |  1988-08-16  |  77.8 KB  |  2,835 lines
  1. C                 S E R V E R   O N L Y   K E R M I T
  2. C
  3. C     written in January, 1986 by Skip Russell using Harris Fortran 77
  4. C
  5. C
  6. C         This program implements the "server" portion of the "Kermit"
  7. C     protocol, as described in version 3 of the protocol manual (see
  8. C     reference below).  It is intended to facilitate the tranfer
  9. C     of files between a Harris computer and other machines.  It
  10. C     incorporates mechanisms to maintain the integrity of data, even
  11. C     over noisy phone lines, etc.  Only the basic server functions
  12. C     have been implemented in this initial version, i.e. send and
  13. C     receive of text (7 bit ascii) files, and the "Finish" command.
  14. C     Other functions/enhancements may be added to future versions
  15. C     and will be documented under "revision history" below.
  16. C
  17. C         I wrote this program especially for use on Harris computers
  18. C     which are configured with a "MUX" as opposed to the more recent
  19. C     CNP or DMACP I/O processors.  As such, I have not taken advantage
  20. C     of many of the special features offered by those devices (notably
  21. C     timeouts and buffered I/O via "hot read"), but have opted instead
  22. C     for simpler, albeit less efficient, modes of communication.  In
  23. C     any case, this program should work properly on a Harris machine
  24. C     in any configuration.
  25. C
  26. C         This program was written using Harris Fortran on a Harris
  27. C     H100-1 computer (VOS 4.1.1 operating system).  It was tested
  28. C     at up to 9600 baud against Columbia University's "MSKERMIT"
  29. C     version 2.27 (see below) on an IBM PC/AT running DOS 3.0.
  30. C
  31. C
  32. C                          -- REFERENCES --
  33. C
  34. C     For a complete discussion of the Kermit design philosophy and
  35. C     detailed descriptions of Kermit commands, see the "KERMIT USER'S
  36. C     GUIDE" by Frank da Cruz, Daphne Tzoar, and Bill Catchings.
  37. C
  38. C     For a detailed description of the Kermit protocol, see the
  39. C     "KERMIT PROTOCOL MANUAL" by Frank da Cruz and Bill Catchings.
  40. C
  41. C     These two documents, as well as general information about Kermit,
  42. C     MSKERMIT and other implementations of Kermit, are available for
  43. C     the cost of distribution, from:
  44. C
  45. C           KERMIT Distribution
  46. C           Columbia University Center for Computing Activities
  47. C           612 West 115th Street
  48. C           7th Floor
  49. C           New York, NY  10025
  50. C
  51. C     or send electronic mail to: Info-Kermit-Request@CU20B.ARPA
  52. C
  53. C
  54. C     Address questions, fixes, comments about this implementation to:
  55. C
  56. C           Skip Russell
  57. C           Washington University School of Medicine
  58. C           Division of Biostatistics
  59. C           Box 8087, 660 South Euclid Avenue
  60. C           St. Louis, Missouri  63110
  61. C
  62. C           electronic mail address: c04689sr@WUVMD.BITNET
  63. C
  64. C
  65. C                       -- REVISION HISTORY --
  66. C
  67. C   (change version number and date in header line if changes are made)
  68. C
  69. C   version 1.00  Jan, 1986, by S.R. : initial release
  70. C
  71. C   version 1.01  Feb, 1986, by S.R. :
  72. C     brought up to version 5 of the protocol manual (dated April 1984)
  73. C     and tested using MSKERMIT version 2.28; also implemented the
  74. C     following remote commands:
  75. C     -- HELP command to issue summary of available remote commands
  76. C     -- LOGOUT ("bye") command to log off the Harris job
  77. C     -- DIRECTORY command to issue information about a single disk
  78. C        area (for now; plan to add wildcard match in future)
  79. C
  80. C   version 1.02  Sept, 1986, by S.R. :
  81. C     -- implemented full DIRECTORY command (wildcard character "?")
  82. C     -- tested using MSKERMIT version 2.29 (dated 26 May 86)
  83. C     -- moved to non-SAU Fortran 77 compiler for portablity
  84. C
  85. C   version 1.03  Nov, 1986, by S.R. :
  86. C     -- brought up to VOS 5.1.0 (required changes in interpretation of
  87. C        file access bits in "REMOTE DIRECTORY" command handler)
  88. C     -- fixed logic in RECVSW to correctly respond to error packets
  89. C
  90. C   version 1.04  April, 1987, by S.R. :
  91. C     -- added code to allow GETs of file groups using the "?" wildcard
  92. C        character.
  93. C
  94. C   version 1.05  May, 1987, by S.R. :
  95. C     -- Corrected error in SWOPEN.  GETs of file groups failed in
  96. C        cases where the qualifier contained trailing blanks.  The fix
  97. C        consisted of enclosing the file name in quotes.
  98. C
  99. C   version 1.06  June, 1987, by S.R. :
  100. C     -- Added code in RDISK to distinguish between EOF and EOT.  Harris
  101. C        disk areas containing embedded EOFs can now be sent without
  102. C        truncating trailing records.  The EOF is sent as a record
  103. C        containing the string "<EOF>".
  104. C
  105. C
  106. C ---------------------------------------------------------------------
  107.  
  108. C     COMMON BLOCKS USED:
  109.  
  110.       LOGICAL           DEBUG
  111.       COMMON /DBGCOM/   DEBUG
  112.       INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  113.       COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  114.       INTEGER           MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
  115.       COMMON /RCVCOM/   MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
  116.  
  117.       INTEGER           MXDATA
  118.       PARAMETER (MXDATA=89)
  119.       INTEGER           DATA(MXDATA),NDATA,NSEQ,ISTAT,MAXTRY
  120.       CHARACTER         TYPE*1
  121.  
  122.       WRITE (3,*) 'HARRIS KERMIT SERVER  --  version 1.06 (June 87) SR'
  123.       WRITE (3,*)
  124.  
  125. C     DEFINE DEFAULT SEND AND RECEIVE SPECS
  126.  
  127.       CALL KSTART
  128.  
  129.       MAXTRY = 10
  130.  
  131. C     WAIT FOR A PACKET TO COME IN, THEN RESPOND
  132.  
  133. 100   CALL RCVPKT(MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
  134.  
  135. C     WE GOT GARBAGE, NAK IT AND TRY AGAIN
  136.       IF (ISTAT .NE. 0) THEN
  137.          NDATA = 0
  138.          CALL SNDNAK(NSEQ)
  139.  
  140. C     WE GOT INIT IN ADVANCE OF SOME FUTURE COMMAND, JUST EXCHANGE INFO
  141.       ELSE IF (TYPE .EQ. 'I') THEN
  142.          CALL INIT(MXDATA,DATA,NDATA,NSEQ)
  143.  
  144. C     LOCAL "SEND" COMMAND (THEY WANT TO SEND A FILE TO US)
  145.       ELSE IF (TYPE .EQ. 'S') THEN
  146.          CALL RECVSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
  147.  
  148. C     LOCAL "GET" COMMAND (THEY WANT A FILE FROM US)
  149.       ELSE IF (TYPE .EQ. 'R') THEN
  150.          CALL SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
  151.  
  152. C     'GENERIC' COMMAND (THEY WANT US TO LOG OFF OR SOMETHING)
  153.       ELSE IF (TYPE .EQ. 'G') THEN
  154.          CALL COMMND(MXDATA,DATA,NDATA,NSEQ,MAXTRY,ISTAT)
  155.          IF (ISTAT .NE. 0) GO TO 999
  156.  
  157. C     WE GOT AN ERROR PACKET, JUST ACKNOWLEDGE IT
  158.       ELSE IF (TYPE .EQ. 'E') THEN
  159.          NDATA = 0
  160.          CALL SNDACK(DATA,NDATA,NSEQ)
  161.  
  162. C     ANYTHING ELSE IS AN ERROR, AS FAR AS WE'RE CONCERNED
  163.       ELSE
  164.          CALL SNDERR('server command not implemented',MXDATA,DATA,NSEQ)
  165.       END IF
  166.       GO TO 100
  167.  
  168. 999   CALL KFINSH
  169.       END
  170.  
  171.       SUBROUTINE KSTART
  172. C---
  173. C--- DEFINE DEFAULT SEND AND RECEIVE SPECS
  174. C---
  175.       LOGICAL           DEBUG
  176.       COMMON /DBGCOM/   DEBUG
  177.       INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  178.       COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  179.       INTEGER           MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
  180.       COMMON /RCVCOM/   MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
  181.  
  182.       INTEGER           IOPT
  183.  
  184. C     HANDLE DEBUG MODE (SPECIFIED USING "KERMIT.D")
  185.  
  186.       CALL OPTION(IOPT)
  187.  
  188.       IF ((IOPT.AND.2**3) .GT. 0) THEN         ! OPTION "D" SPECIFIED
  189.          DEBUG = .TRUE.
  190.          IOPT  = IOPT .XOR. 2**3
  191.       ELSE                                     ! NOT SPECIFIED
  192.          DEBUG = .FALSE.
  193.       END IF
  194.  
  195.       IF (IOPT.NE.0) STOP "*ERROR* valid option is 'D' for debug mode"
  196.  
  197.       IF (DEBUG) THEN
  198.          WRITE (3,*) '[writing packet contents to LO for debugging]'
  199.       ELSE
  200.          WRITE (3,*) '[logging names of send/receive files to LO]'
  201.       END IF
  202.       WRITE (3,*)
  203.  
  204. C     DEFAULT SEND SPECS
  205.  
  206.       MSPSIZ = 94                   ! BIGGEST PACKET THEY CAN RECEIVE
  207.       NSTIME = 0                    ! WHEN THEY WANT TIMEOUT
  208.       NSPAD  = 0                    ! HOW MUCH PADDING TO SEND THEM
  209.       NSPCHR = 0                    ! PAD CHARACTER TO USE
  210.       NSEOL  = 13                   ! EOL TO SEND THEM (CR)
  211.       NSQUOT = ICHAR('#')           ! INCOMING DATA QUOTE CHARACTER
  212.  
  213. C     DEFAULT RECEIVE SPECS
  214.  
  215.       MRPSIZ = 78                   ! BIGGEST PACKET I CAN RECEIVE
  216.       MYTIME = 13                   ! WHEN I WANT TIMEOUT
  217.       MYPAD  = 0                    ! HOW MUCH PADDING TO SEND ME
  218.       MYPCHR = 10                   ! PAD CHARACTER TO USE (LINEFEED)
  219.       MYEOL  = 13                   ! EOL TO SEND ME (CR)
  220.       MYQUOT = ICHAR('#')           ! QUOTE CHARACTER I WILL SEND THEM
  221.  
  222. CCCC     WARN ABOUT XON/XOFF IF CONTROL/S IS AN ABORT CHAR ON THIS
  223. CCCC     MACHINE
  224. CCC
  225. CCC      WRITE (3,*) 'DO NOT USE XON/XOFF (SET FLOW NONE)'
  226.  
  227.       WRITE (3,*)
  228.       WRITE (3,*) 'SERVER MODE ENABLED -- type the appropriate key'
  229.       WRITE (3,*) 'sequence to escape back to your local Kermit...'
  230.       END
  231.  
  232.       SUBROUTINE KFINSH
  233. C---
  234. C--- CLOSE UP
  235. C---
  236.       INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  237.       COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  238.  
  239.       CALL PUT1CW(NSEOL,1)
  240.  
  241.       CLOSE (UNIT=6)
  242.       CLOSE (UNIT=7)
  243.       CLOSE (UNIT=50)
  244.       END
  245.  
  246.       SUBROUTINE INIT(MXDATA,DATA,NDATA,NSEQ)
  247. C---
  248. C--- HANDLE INITIAL PACKET, RESPOND WITH ACK AND OUR PARAMETERS
  249. C---
  250.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ
  251.  
  252. C     READ THEIR PACKET
  253.  
  254.       CALL RPAR(DATA,NDATA)
  255.  
  256. C     ACK WITH OUR INIT PACKET
  257.  
  258.       CALL SPAR(MXDATA,DATA,NDATA)
  259.       CALL SNDACK(DATA,NDATA,NSEQ)
  260.       END
  261. C TRANSMIT SUBROUTINES
  262. C
  263. C     SENDSW   -- STATE TABLE SWITCHER FOR SENDING FILES
  264. C     SOPEN    -- OPENS FILE TO SEND TO RECEIVING KERMIT
  265. C     SINIT    -- EXCHANGE SEND/RECEIVE INFO WITH RECEIVING KERMIT
  266. C     SFILE    -- SENDS FILE NAME TO RECEIVING KERMIT
  267. C     SDATA    -- SENDS FILE CONTENTS TO RECEIVING KERMIT
  268. C     SEOF     -- SENDS "END-OF-FILE" PACKET TO RECEIVING KERMIT
  269. C     SBREAK   -- SENDS "BREAK" PACKET TO RECEIVING KERMIT
  270. C     RDISK    -- READS A SINGLE CHARACTER FROM A DISK FILE
  271. C     SWINIT   -- EXPANDS LIST OF WILDCARD FILE NAMES
  272. C     SWOPEN   -- OPENS THE NEXT FILE IN A LIST OF WILDCARD FILENAMES
  273. C     SWCLOS   -- CLOSES THE LIST OF WILDCARD FILE NAMES
  274. C
  275. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  276.  
  277.       SUBROUTINE SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
  278. C---
  279. C--- THIS IS THE STATE TABLE SWITCHER FOR SENDING FILES.
  280. C--- IT LOOPS UNTIL EITHER IT IS FINISHED OR A FAULT IS ENCOUNTERED.
  281. C---
  282.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ,MAXTRY
  283.  
  284.       LOGICAL           DEBUG
  285.       COMMON /DBGCOM/   DEBUG
  286.  
  287.       CHARACTER         STATE*1
  288.       INTEGER           NUMTRY,ISTAT
  289.  
  290. C     ASSIGN THE FILE
  291.  
  292.       CALL SOPEN(MXDATA,DATA,NDATA,NSEQ,ISTAT)
  293.       IF (ISTAT .NE. 0) GO TO 800
  294.  
  295.       STATE = 'S'
  296.       NSEQ = 0
  297.  
  298. 100   CONTINUE
  299.  
  300.       FOR NUMTRY=1,MAXTRY
  301.          IF      (STATE .EQ. 'S') THEN       ! SEND INIT PACKET
  302.             CALL SINIT(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
  303.  
  304.          ELSE IF (STATE .EQ. 'F') THEN       ! SEND FILE-HEADER PACKET
  305.             CALL SFILE(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
  306.  
  307.          ELSE IF (STATE .EQ. 'D') THEN       ! SEND FILE-DATA PACKET
  308.             CALL SDATA(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
  309.  
  310.          ELSE IF (STATE .EQ. 'Z') THEN       ! SEND EOF PACKET
  311.             CALL SEOF(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
  312.  
  313.          ELSE IF (STATE .EQ. 'B') THEN       ! SEND BREAK (EOT) PACKET
  314.             CALL SBREAK(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
  315.  
  316.          ELSE IF (STATE .EQ. 'C') THEN       ! COMPLETE
  317.             GO TO 900
  318.  
  319.          ELSE IF (STATE .EQ. 'A') THEN       ! ABORT
  320.             GO TO 800
  321.  
  322.          ELSE
  323.             WRITE (*,*) 'FATAL ERROR: INVALID STATE IN "SENDSW"'
  324.             STOP
  325.          END IF
  326.          IF (ISTAT .EQ. 0) GO TO 500
  327.       END FOR
  328.       CALL SNDERR('too many retries',MXDATA,DATA,NSEQ)
  329.       GO TO 800
  330.  
  331. 500   NSEQ = MOD( NSEQ+1, 64 )
  332.       GO TO 100
  333.  
  334. 800   IF (DEBUG) WRITE (*,*) '--- ABORT ---'
  335.       RETURN
  336.  
  337. 900   IF (DEBUG) WRITE (*,*) '=== SEND COMPLETE ==='
  338.       RETURN
  339.       END
  340.  
  341.       SUBROUTINE SOPEN(MXDATA,DATA,NDATA,NSEQ,ISTAT)
  342. C---
  343. C--- OPEN FILE TO SEND THEM
  344. C---
  345.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT
  346.  
  347.       LOGICAL           DEBUG
  348.       COMMON /DBGCOM/   DEBUG
  349.  
  350.       CHARACTER         FILNAM*19
  351.       LOGICAL           QMARK
  352.       INTEGER           I
  353.  
  354.       FILNAM = ' '
  355.       QMARK = .FALSE.
  356.  
  357.       FOR I=1,MIN( NDATA, LEN(FILNAM) )
  358.          FILNAM(I:I) = CHAR( DATA(I) )
  359.          IF ( DATA(I) .EQ. ICHAR('?') ) QMARK = .TRUE.
  360.       END FOR
  361.  
  362. C     CHECK FOR VALID WILDCARD FILE NAME AND OPEN THE FIRST FILE
  363.  
  364.       IF (QMARK) THEN
  365.          CALL SWINIT(FILNAM,MXDATA,DATA,NDATA,NSEQ,ISTAT)
  366.  
  367.       ELSE
  368.          CALL SWCLOS()
  369.  
  370. C     CHECK FOR VALID FILE NAME AND OPEN THE FILE
  371.  
  372.          WRITE (*,*) 'OPENING ', FILNAM(1:NDATA), ' FOR SEND'
  373.  
  374.          OPEN (UNIT=50, FILE=FILNAM, STATUS='OLD', IOSTAT=ISTAT)
  375.  
  376.          IF (ISTAT .NE. 0) THEN
  377.             CALL SNDERR('can''t find specified file',MXDATA,DATA,NSEQ)
  378.          END IF
  379.  
  380.       END IF
  381.       END
  382.  
  383.       SUBROUTINE SINIT(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
  384. C---
  385. C--- SEND INIT PACKET AND GET THEIRS IN RESPONSE
  386. C---
  387.       CHARACTER         STATE*1
  388.       INTEGER           NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT
  389.  
  390.       INTEGER           NDATA,RSEQ
  391.  
  392. C     SEND OUR INIT PACKET
  393.  
  394.       CALL SPAR(MXDATA,DATA,NDATA)
  395.  
  396.       CALL SNDPKT(DATA,NDATA,NSEQ,'S')
  397.  
  398. C     GET THEIR INIT PACKET IN RESPONSE
  399.  
  400.       CALL RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT)
  401.       IF (ISTAT .LT. 0) GO TO 800   ! RECEIVED ERR
  402.       IF (ISTAT .NE. 0) GO TO 810   ! RECEIVED NAK
  403.  
  404. 100   CALL RPAR(DATA,NDATA)
  405.       GO TO 900
  406.  
  407. 800   ISTAT = -1  ! ABORT
  408.       STATE = 'A'
  409.       RETURN
  410.  
  411. 810   ISTAT = 1   ! UNSUCCESSFUL
  412.       RETURN
  413.  
  414. 900   ISTAT = 0   ! SUCCESSFUL
  415.       STATE = 'F'
  416.       RETURN
  417.       END
  418.  
  419.       SUBROUTINE SFILE(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
  420. C---
  421. C--- SEND FILE HEADER PACKET
  422. C---
  423.       CHARACTER         STATE*1
  424.       INTEGER           NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT
  425.  
  426.       LOGICAL           DEBUG
  427.       COMMON /DBGCOM/   DEBUG
  428.  
  429.       CHARACTER         FILNAM*17
  430.       LOGICAL           OPENED,NAMED
  431.       INTEGER           NDATA,MXRCV,C,I
  432.  
  433. C     SEND FILE NAME
  434.  
  435.       IF (NUMTRY .EQ. 1) THEN
  436.          INQUIRE (UNIT=50, OPENED=OPENED, NAMED=NAMED, NAME=FILNAM)
  437.          IF (.NOT. (OPENED .AND. NAMED) ) THEN
  438.             CALL SNDERR('read file error',MXDATA,DATA,NSEQ)
  439.             GO TO 800
  440.          END IF
  441.  
  442.          NDATA = 0
  443.          FOR I=9,16  ! AREANAME
  444.             C = ICHAR( FILNAM(I:I) )
  445.             DATA(I-8) = C
  446.             IF (C .NE. ICHAR(' ')) NDATA = I-8
  447.          END FOR
  448. CCC
  449. CCC THE FOLLOWING LINES ARE COMMENTED OUT.  THEY CAN BE RESTORED
  450. CCC IF ONE DESIRES TO USE THE FIRST THREE ALPHABETIC CHARACTERS
  451. CCC OF THE QUALIFIER AS THE FILENAME EXTENSION, E.G. FOR DOS MACHINES.
  452. CCC
  453. CCC         NDATA = NDATA + 1
  454. CCC         DATA(NDATA) = ICHAR('.')
  455. CCC         FOR I=5,7   ! PART OF QUALIFIER
  456. CCC            C = ICHAR( FILNAM(I:I) )
  457. CCC            IF (C .NE. ICHAR(' ')) THEN
  458. CCC               NDATA = NDATA + 1
  459. CCC               DATA(NDATA) = C
  460. CCC            END IF
  461. CCC         END FOR
  462.  
  463.          CALL SNDPKT(DATA,NDATA,NSEQ,'F')
  464.       ELSE
  465.          CALL RESEND
  466.       END IF
  467.  
  468. C     GET THEIR RESPONSE
  469.  
  470.       MXRCV = 0
  471.       CALL RCVACK(MXRCV,DATA,NDATA,NSEQ,ISTAT)
  472.       IF (ISTAT .LT. 0) GO TO 800   ! RECEIVED ERR
  473.       IF (ISTAT .NE. 0) GO TO 810   ! RECEIVED NAK
  474.  
  475. C     PREPARE TO READ FILE
  476.  
  477.       CALL RDINIT(ISTAT)
  478.       IF (ISTAT .NE. 0) GO TO 910
  479.       GO TO 900
  480.  
  481. 800   ISTAT = -1  ! ABORT
  482.       STATE = 'A'
  483.       RETURN
  484.  
  485. 810   ISTAT = 1   ! UNSUCCESSFUL
  486.       RETURN
  487.  
  488. 900   ISTAT = 0   ! SUCCESSFUL
  489.       STATE = 'D'
  490.       RETURN
  491.  
  492. 910   ISTAT = 0   ! SUCCESSFUL BUT EMPTY FILE
  493.       STATE = 'Z'
  494.       RETURN
  495.       END
  496.  
  497.       SUBROUTINE SDATA(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
  498. C---
  499. C--- SEND FILE DATA PACKET
  500. C---
  501.       CHARACTER         STATE*1
  502.       INTEGER           NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT
  503.  
  504.       INTEGER           MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
  505.       COMMON /RCVCOM/   MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
  506.  
  507.       LOGICAL           ISCTRL
  508.       INTEGER           CTL
  509.       LOGICAL           EOF
  510.       INTEGER           NDATA,NEWCHR,MXRCV
  511.  
  512. C     GET NEXT PACKETFULL OF DATA AND SEND IT
  513.  
  514.       IF (NUMTRY .EQ. 1) THEN
  515.          NDATA = 0
  516.          EOF = .FALSE.
  517.  
  518. C        GET NEXT CHARACTER FROM THE DISK FILE
  519. 100      IF (EOF .OR. NDATA+2 .GT. MXDATA) GO TO 200
  520.  
  521.          CALL RDISK(NEWCHR,ISTAT)
  522.          IF (ISTAT .NE. 0) EOF = .TRUE.
  523.  
  524. C        QUOTE IF SPECIAL CHARACTER, THEN COPY TO THE PACKET BUFFER
  525.          IF ( ISCTRL(NEWCHR) .OR. (NEWCHR .EQ. MYQUOT) ) THEN
  526.             NDATA = NDATA + 1
  527.             DATA(NDATA) = MYQUOT
  528.             IF ( NEWCHR .NE. MYQUOT ) NEWCHR = CTL(NEWCHR)              SR 9/86
  529.          END IF
  530.  
  531.          NDATA = NDATA + 1
  532.          DATA(NDATA) = NEWCHR
  533.          GO TO 100
  534.  
  535. 200      CALL SNDPKT(DATA,NDATA,NSEQ,'D')
  536.       ELSE
  537.          CALL RESEND
  538.       END IF
  539.  
  540. C     GET THEIR RESPONSE
  541.  
  542.       MXRCV = 0
  543.       CALL RCVACK(MXRCV,DATA,NDATA,NSEQ,ISTAT)
  544.       IF (ISTAT .LT. 0) GO TO 800   ! RECEIVED ERR
  545.       IF (ISTAT .NE. 0) GO TO 810   ! RECEIVED NAK
  546.       IF (EOF) GO TO 910
  547.       GO TO 900
  548.  
  549. 800   ISTAT = -1  ! ABORT
  550.       STATE = 'A'
  551.       RETURN
  552.  
  553. 810   ISTAT = 1   ! UNSUCCESSFUL
  554.       RETURN
  555.  
  556. 900   ISTAT = 0   ! SUCCESSFUL
  557.       RETURN
  558.  
  559. 910   ISTAT = 0   ! SUCCESSFUL AND AT END-OF-FILE
  560.       STATE = 'Z'
  561.       RETURN
  562.       END
  563.  
  564.       SUBROUTINE SEOF(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
  565. C---
  566. C--- SEND END-OF-FILE PACKET
  567. C---
  568.       CHARACTER         STATE*1
  569.       INTEGER           NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT
  570.  
  571.       LOGICAL           WLDSND
  572.       COMMON /SWCOM/    WLDSND
  573.  
  574.       INTEGER           NDATA
  575.  
  576. C     CLOSE FILE AND SEND EMPTY "Z" PACKET
  577.  
  578.       IF (NUMTRY .EQ. 1) THEN
  579.          CALL RDCLOS
  580.          NDATA = 0
  581.          CALL SNDPKT(DATA,NDATA,NSEQ,'Z')
  582.       ELSE
  583.          CALL RESEND
  584.       END IF
  585.  
  586. C     GET THEIR RESPONSE
  587.  
  588.       CALL RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT)
  589.       IF (ISTAT .LT. 0) GO TO 800   ! RECEIVED ERR
  590.       IF (ISTAT .NE. 0) GO TO 810   ! RECEIVED NAK
  591.       WRITE (*,*) '=SEND OF CURRENT FILE COMPLETE='
  592.  
  593. C     IF THERE ARE MORE FILES TO SEND, OPEN THE NEXT FILE
  594.       IF (WLDSND) THEN
  595.          CALL SWOPEN(ISTAT)
  596.          IF (ISTAT .LT. 0) THEN
  597.             CALL SNDERR('can''t find specified file',MXDATA,DATA,NSEQ)
  598.             GO TO 800
  599.          END IF
  600.       END IF
  601.       GO TO 900
  602.  
  603. 800   ISTAT = -1  ! ABORT
  604.       STATE = 'A'
  605.       RETURN
  606.  
  607. 810   ISTAT = 1   ! UNSUCCESSFUL
  608.       RETURN
  609.  
  610. 900   ISTAT = 0   ! SUCCESSFUL
  611.       IF (WLDSND) THEN
  612.          STATE = 'F'
  613.       ELSE
  614.          STATE = 'B'
  615.       END IF
  616.       RETURN
  617.       END
  618.  
  619.       SUBROUTINE SBREAK(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT)
  620. C---
  621. C--- SEND END-OF-FILE PACKET
  622. C---
  623.       CHARACTER         STATE*1
  624.       INTEGER           NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT
  625.  
  626.       INTEGER           NDATA
  627.  
  628. C     SEND EMPTY "B" PACKET
  629.  
  630.       NDATA = 0
  631.       CALL SNDPKT(DATA,NDATA,NSEQ,'B')
  632.  
  633. C     GET THEIR RESPONSE
  634.  
  635.       CALL RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT)
  636.       IF (ISTAT .LT. 0) GO TO 800   ! RECEIVED ERR
  637.       IF (ISTAT .NE. 0) GO TO 810   ! RECEIVED NAK
  638.       GO TO 900
  639.  
  640. 800   ISTAT = -1  ! ABORT
  641.       STATE = 'A'
  642.       RETURN
  643.  
  644. 810   ISTAT = 1   ! UNSUCCESSFUL
  645.       RETURN
  646.  
  647. 900   ISTAT = 0   ! SUCCESSFUL
  648.       STATE = 'C'
  649.       RETURN
  650.       END
  651.  
  652.       SUBROUTINE RDISK(NEWCHR,ISTAT)
  653. C---
  654. C--- READS A SINGLE CHARACTER FROM A DISK FILE
  655. C---
  656. C--- ENTRY POINT "RDINIT" INITIALIZES
  657. C--- ENTRY POINT "RDCLOS" FINISHES
  658. C---
  659.       INTEGER           NEWCHR,ISTAT
  660.  
  661.       LOGICAL           DEBUG
  662.       COMMON /DBGCOM/   DEBUG
  663.  
  664.       INTEGER    MAXW,MAXC
  665.       PARAMETER (MAXW=100, MAXC=3*MAXW)
  666.       INTEGER           BUFW(MAXW)
  667.       INTEGER*1         BUFC(MAXC+9)
  668.       EQUIVALENCE (BUFW,BUFC)
  669.  
  670.       LOGICAL           EOF
  671.       INTEGER           IBUF,NBUF,NBUFW,CR,LF,I
  672.       SAVE              EOF,BUFW,IBUF,NBUF
  673.  
  674.       DATA EOF /.TRUE./
  675.       DATA CR, LF /13, 10/
  676.  
  677.       IF (EOF) THEN
  678.          IF (DEBUG) WRITE (*,*) '*FATAL ERROR*  RDISK NOT INITIALIZED'
  679.          STOP
  680.       END IF
  681.  
  682. C     GET NEXT CHARACTER FROM BUFFER
  683.       IBUF = IBUF + 1
  684.       NEWCHR = BUFC(IBUF)
  685.  
  686. C     SEE IF WE HAVE JUST EMPTIED THE BUFFER
  687. 100   IF (IBUF .GE. NBUF) THEN
  688.          IBUF = 0
  689.          NBUF = 0
  690.  
  691. C        READ NEXT RECORD FROM DISK
  692.          BUFFER IN(50,BUFW,S,MAXW,ISTAT,NBUFW)
  693.          CALL STATUS(50)
  694.          IF (ISTAT .NE. 2 .AND. ISTAT .NE. 3) THEN
  695.             IF (DEBUG .AND. ISTAT .NE. 4)
  696.      +         WRITE (*,*) 'RDISK: DISK READ ERROR ON BUFFER IN', ISTAT
  697.             EOF = .TRUE.
  698.             GO TO 800
  699.          END IF
  700.  
  701. C        FIND LENGTH TO LAST NON-BLANK
  702.          FOR I=NBUFW*3,1,-1
  703.             IF (BUFC(I) .NE. ICHAR(' ')) THEN
  704.                NBUF = I
  705.                EXIT FOR
  706.             END IF
  707.          END FOR
  708.  
  709. C        APPEND "<EOF>" IF AN EMBEDDED EOF WAS FOUND
  710.          IF (ISTAT .EQ. 3) THEN
  711.             IF (DEBUG) WRITE (*,*) '(FOUND EMBEDDED EOF)'
  712.             IF (NBUF .GT. 0) THEN
  713.                NBUF = NBUF + 1
  714.                BUFC(NBUF) = CR
  715.                NBUF = NBUF + 1
  716.                BUFC(NBUF) = LF
  717.             END IF
  718.             NBUF = NBUF + 1
  719.             BUFC(NBUF) = '<'
  720.             NBUF = NBUF + 1
  721.             BUFC(NBUF) = 'E'
  722.             NBUF = NBUF + 1
  723.             BUFC(NBUF) = 'O'
  724.             NBUF = NBUF + 1
  725.             BUFC(NBUF) = 'F'
  726.             NBUF = NBUF + 1
  727.             BUFC(NBUF) = '>'
  728.          END IF
  729.  
  730. C        APPEND CR/LF
  731.          NBUF = NBUF + 1
  732.          BUFC(NBUF) = CR
  733.          NBUF = NBUF + 1
  734.          BUFC(NBUF) = LF
  735.  
  736.       END IF
  737.       GO TO 900
  738.  
  739. 800   ISTAT = 1   ! EOF OR ERROR (CURRENT CHARACTER IS THE LAST ONE)
  740.       RETURN
  741.  
  742. 900   ISTAT = 0   ! SUCCESSFUL
  743.       RETURN
  744.  
  745. C---
  746. C--- INITIALIZE AND READ FIRST RECORD
  747. C---
  748.       ENTRY RDINIT(ISTAT)
  749.  
  750.       IBUF = 0
  751.       NBUF = 0
  752.       EOF = .FALSE.
  753.       GO TO 100
  754.  
  755. C---
  756. C--- CLOSE FILE
  757. C---
  758.       ENTRY RDCLOS
  759.  
  760.       IF (.NOT. EOF) THEN
  761.          IF (DEBUG) WRITE (*,*) '*WARNING* SENT INCOMPLETE FILE'
  762.          NBUF = 0
  763.       END IF
  764.       CLOSE (UNIT=50)
  765.       RETURN
  766.       END
  767.  
  768.       SUBROUTINE SWINIT(AREANM,MXDATA,DATA,NDATA,NSEQ,ISTAT)
  769. C---
  770. C--- ASSEMBLE A LIST OF NAMES OF FILES TO SEND IN RESPONSE TO A
  771. C--- "GET" COMMAND CONTAINING WILDCARD CHARACTERS
  772. C---
  773.       CHARACTER         AREANM*(*)
  774.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT
  775.  
  776.       CHARACTER         DIRFIL*17, ERRMSG*80
  777.       LOGICAL           SIZEORD
  778.       INTEGER           LFN,NARGC,NEWCHR,I
  779.  
  780.       DATA DIRFIL /'W1'/
  781.       DATA LFN /99/
  782.  
  783. C     CONVERT THE FILE NAME TO UPPER CASE
  784.  
  785.       NARGC = MIN( NDATA, LEN(AREANM) )
  786.       FOR I=1,NARGC
  787.          NEWCHR = ICHAR( AREANM(I:I) )
  788.          IF (NEWCHR .GT. ICHAR('a') .AND. NEWCHR .LT. ICHAR('z') ) THEN
  789.             NEWCHR = NEWCHR - ICHAR('a') + ICHAR('A')
  790.             AREANM(I:I) = CHAR( NEWCHR )
  791.          END IF
  792.       END FOR
  793.  
  794. C     OPEN A DIRECTORY WORKFILE
  795.  
  796.       OPEN (UNIT=LFN, FILE=DIRFIL, STATUS='OLD', IOSTAT=ISTAT)
  797.       IF (ISTAT .NE. 0) GO TO 810
  798.  
  799.       REWIND (UNIT=LFN)
  800.  
  801. C     WRITE DIRECTORY INFORMATION TO THE WORKFILE
  802.  
  803.       SIZEORD  = .FALSE.
  804.  
  805.       CALL DIR(LFN,AREANM,NARGC,SIZEORD,ERRMSG,ISTAT)
  806.       IF (ISTAT .NE. 0) GO TO 800
  807.  
  808. C     PREPARE TO SEND THE FIRST FILE
  809.       REWIND (UNIT=LFN)
  810.  
  811.       CALL SWOPEN(ISTAT)
  812.       IF (ISTAT .NE. 0) GO TO 820
  813.       GO TO 900
  814.  
  815. 800   CALL SNDERR(ERRMSG,MXDATA,DATA,NSEQ)
  816.       CLOSE (UNIT=LFN)
  817.       RETURN
  818.  
  819. 810   CALL SNDERR('directory workfile inaccessable',MXDATA,DATA,NSEQ)
  820.       RETURN
  821.  
  822. 820   CALL SNDERR('file not accessible',MXDATA,DATA,NSEQ)
  823.       RETURN
  824.  
  825. 900   RETURN
  826.       END
  827.  
  828.       SUBROUTINE SWOPEN(ISTAT)
  829. C---
  830. C--- OPEN THE NEXT FILE IN A LIST OF FILES TO SEND
  831. C---
  832.       INTEGER           ISTAT
  833.  
  834.       CHARACTER         FILNAM*19, BUF*80
  835.       INTEGER           LFN
  836.  
  837.       LOGICAL           WLDSND
  838.       COMMON /SWCOM/    WLDSND
  839.  
  840.       DATA LFN /99/
  841.  
  842. C     READ NEXT ENTRY FROM THE FILE NAME LIST
  843.       DO
  844.          READ (LFN, '(A)', END=800) BUF
  845.       UNTIL ( BUF(9:9) .EQ. '*' .OR. BUF(16:16) .EQ. '*' )
  846.  
  847.       IF ( BUF(9:9) .EQ. '*' ) THEN
  848.          FILNAM = '"' // BUF(1:17) // '"'
  849.       ELSE
  850.          FILNAM = '"' // BUF(8:24) // '"'
  851.       END IF
  852.  
  853.       WRITE (*,*) 'OPENING ', FILNAM, ' FOR SEND'
  854.  
  855.       OPEN (UNIT=50, FILE=FILNAM, STATUS='OLD', IOSTAT=ISTAT)
  856.       IF (ISTAT .NE. 0) GO TO 810
  857.       GO TO 900
  858.  
  859. 800   ISTAT = 1   ! NO MORE FILE NAMES IN LIST
  860.       CALL SWCLOS()
  861.       WLDSND = .FALSE.
  862.       RETURN
  863.  
  864. 810   ISTAT = -1  ! FILE OPEN UNSUCCESFUL
  865.       WLDSND = .FALSE.
  866.       RETURN
  867.  
  868. 900   ISTAT = 0   ! FILE OPEN SUCCESFUL
  869.       WLDSND = .TRUE.
  870.       END
  871.  
  872.       SUBROUTINE SWCLOS()
  873. C---
  874. C--- CLOSE THE FILE CONTAINING THE LIST OF FILES TO SEND
  875. C---
  876.       INTEGER           LFN
  877.  
  878.       LOGICAL           WLDSND
  879.       COMMON /SWCOM/    WLDSND
  880.  
  881.       DATA LFN /99/
  882.  
  883. C     IF THE FILE IS OPEN, CLOSE IT
  884.       IF (WLDSND) THEN
  885.          CLOSE (UNIT=LFN)
  886.          WLDSND = .FALSE.
  887.       END IF
  888.       END
  889. C RECEIVE SUBROUTINES
  890. C
  891. C     RECVSW   -- PACKET TYPE SWITCHER FOR RECEIVING FILES
  892. C     RINIT    -- EXCHANGE SEND/RECEIVE INFO WITH SENDING KERMIT
  893. C     RFILE    -- RECIEVES FILE NAME AND CREATES RECEIVE FILE
  894. C     RDATA    -- RECEIVES FILE CONTENTS FROM SENDING KERMIT
  895. C     REOF     -- RECEIVES "END-OF-FILE" PACKET FROM SENDING KERMIT
  896. C     RBREAK   -- RECEIVES "BREAK" PACKET FROM SENDING KERMIT
  897. C     WDISK    -- WRITES A SINGLE CHARACTER TO A DISK FILE
  898. C     ENPAD    -- PADS OUTPUT RECORD TO A WORD BOUNDARY
  899. C     DELFIL   -- DELETES A FILE PARTIALLY RECEIVED
  900. C
  901. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  902.  
  903.       SUBROUTINE RECVSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
  904. C---
  905. C--- THIS IS THE PACKET TYPE SWITCHER FOR RECEIVING FILES.
  906. C--- IT LOOPS UNTIL EITHER IT IS FINISHED OR A FAULT IS ENCOUNTERED.
  907. C---
  908.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ,MAXTRY
  909.  
  910.       LOGICAL           DEBUG
  911.       COMMON /DBGCOM/   DEBUG
  912.  
  913.       LOGICAL           FILOPN
  914.       INTEGER           NUMTRY,OLDSEQ,ISTAT
  915.       CHARACTER         STATE*1,TYPE*1
  916.  
  917.       STATE = 'I'
  918.       TYPE = 'I'
  919.       FILOPN = .FALSE.
  920.       OLDSEQ = NSEQ
  921.  
  922. 100   IF      (TYPE .EQ. 'I') THEN           ! GOT INIT PACKET
  923.          CALL RINIT(STATE,MXDATA,DATA,NDATA,NSEQ)
  924.  
  925.       ELSE IF (TYPE .EQ. 'F') THEN           ! GOT FILE-HEADER PACKET
  926.          CALL RFILE(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT)
  927.          IF (ISTAT .EQ. 0) FILOPN = .TRUE.
  928.  
  929.       ELSE IF (TYPE .EQ. 'D') THEN           ! GOT FILE-DATA PACKET
  930.          CALL RDATA(STATE,MXDATA,DATA,NDATA,NSEQ)
  931.  
  932.       ELSE IF (TYPE .EQ. 'Z') THEN           ! GOT EOF PACKET
  933.          CALL REOF(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT)
  934.          IF (ISTAT .EQ. 0) FILOPN = .FALSE.
  935.  
  936.       ELSE IF (TYPE .EQ. 'B') THEN           ! GOT BREAK PACKET
  937.          CALL RBREAK(STATE,MXDATA,DATA,NDATA,NSEQ)
  938.  
  939.       ELSE IF (TYPE .EQ. 'E') THEN           ! GOT ERROR PACKET
  940.          NDATA = 0
  941.          CALL SNDACK(DATA,NDATA,NSEQ)
  942.          STATE = 'A'
  943.  
  944.       ELSE
  945.          IF (DEBUG) WRITE (*,*) 'INVALID PACKET TYPE'
  946.          STATE = 'A'
  947.       END IF
  948.  
  949.       IF (STATE .EQ. 'A') GO TO 800          ! ABORT
  950.  
  951.       IF (STATE .EQ. 'C') GO TO 900          ! COMPLETE
  952.  
  953. C     RECEIVE A NEW PACKET
  954.       FOR NUMTRY=1,MAXTRY
  955.  
  956.          CALL RCVPKT(MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
  957.          IF (ISTAT .EQ. 0) THEN
  958.  
  959. C           GOT THE RIGHT PACKET?
  960. CCC            IF (NSEQ .EQ. MOD( OLDSEQ+1, 64 ) ) THEN                 SR11/86
  961.             IF (NSEQ .EQ. MOD( OLDSEQ+1, 64 ) .OR. TYPE .EQ. 'E') THEN  SR11/86
  962.                OLDSEQ = NSEQ
  963.                GO TO 100
  964.  
  965. C           NO. GOT PREVIOUS PACKET AGAIN BY MISTAKE?
  966.             ELSE IF (NSEQ .EQ. OLDSEQ) THEN
  967.                IF (NUMTRY .LT. MAXTRY) CALL RESEND
  968.                GO TO 200
  969.             END IF
  970.          END IF
  971.  
  972. C        NO. NAK IT AND TRY AGAIN UP TO MAXTRY TIMES
  973.          IF (NUMTRY .LT. MAXTRY) CALL SNDNAK(NSEQ)
  974.  
  975. 200      CONTINUE
  976.       END FOR
  977.       CALL SNDERR('too many retries',MXDATA,DATA,NSEQ)
  978.       GO TO 800
  979.  
  980. 800   IF (DEBUG) WRITE (*,*) '--- ABORT ---'
  981.       IF (FILOPN) CALL DELFIL                ! ERASE PARTIAL FILE
  982.       RETURN
  983.  
  984. 900   IF (DEBUG) WRITE (*,*) '=== RECEIVE COMPLETE ==='
  985.       RETURN
  986.       END
  987.  
  988.       SUBROUTINE RINIT(STATE,MXDATA,DATA,NDATA,NSEQ)
  989. C---
  990. C--- GOT RECEIVE-INIT PACKET, RESPOND WITH ACK AND OUR PARAMETERS
  991. C---
  992.       CHARACTER         STATE*1
  993.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ
  994.  
  995.       CALL INIT(MXDATA,DATA,NDATA,NSEQ)
  996.  
  997.       STATE = 'F'
  998.       END
  999.  
  1000.       SUBROUTINE RFILE(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT)
  1001. C---
  1002. C--- GOT FILE HEADER PACKET, CREATE THE SPECIFED FILE
  1003. C---
  1004.       CHARACTER         STATE*1
  1005.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT
  1006.  
  1007.       LOGICAL           DEBUG
  1008.       COMMON /DBGCOM/   DEBUG
  1009.  
  1010.       LOGICAL           WRKFIL
  1011.       CHARACTER         FILNAM*40
  1012.       INTEGER           IDOT,IAST,I
  1013.  
  1014.       IF (STATE .NE. 'F') THEN
  1015.          CALL SNDERR('not expecting F packet',MXDATA,DATA,NSEQ)
  1016.          GO TO 800
  1017.       END IF
  1018.  
  1019. C     ASSEMBLE HARRIS FILE NAME
  1020.  
  1021.       FILNAM = ' '
  1022.       IDOT = 0
  1023.       IAST = 0
  1024.       NDATA = MIN( NDATA, MXDATA, LEN(FILNAM) )
  1025.  
  1026.       FOR I=1,NDATA
  1027.          FILNAM(I:I) = CHAR( DATA(I) )
  1028.          IF (FILNAM(I:I) .EQ. '.') IDOT = I
  1029.          IF (FILNAM(I:I) .EQ. '*') IAST = I
  1030.       END FOR
  1031.  
  1032.       IF (IDOT .GT. 0 .AND. IAST .EQ. 0) THEN
  1033. C        TRANSLATE IBM-PC STYLE FILENAME
  1034.          IF (IDOT .EQ. NDATA) THEN
  1035.             NDATA = MIN( 8, IDOT-1 )
  1036.          ELSE IF (NDATA .GT. 8) THEN
  1037.             NDATA = 8
  1038.             IF (IDOT .GT. 7) FILNAM(7:8) = '.' // CHAR( DATA(IDOT+1) )
  1039.          END IF
  1040.       END IF
  1041.  
  1042. C     MAKE SURE THE FILE NAME IS VALID AND RESPOND
  1043.  
  1044.       WRITE (*,*) 'OPENING FILE ', FILNAM(1:NDATA), ' FOR RECEIVE'
  1045.       OPEN(UNIT=50, FILE=FILNAM(1:NDATA), STATUS='OLD', IOSTAT=ISTAT)
  1046.  
  1047.       IF (ISTAT .EQ. 0) THEN
  1048.          IF (WRKFIL(50)) GO TO 200
  1049.          CLOSE (UNIT=50)
  1050.          CALL SNDERR( FILNAM(1:NDATA) // ' exists', MXDATA,DATA,NSEQ)
  1051.          GO TO 800
  1052.       END IF
  1053.  
  1054.       OPEN(UNIT=50, FILE=FILNAM(1:NDATA), STATUS='NEW', IOSTAT=ISTAT)
  1055.  
  1056.       IF (ISTAT .NE. 0) THEN
  1057. C        CAN'T CREATE FILE
  1058.          CALL SNDERR( 'filename ' // FILNAM(1:NDATA) // ' is invalid',
  1059.      +      MXDATA,DATA,NSEQ)
  1060.          GO TO 800
  1061.       END IF
  1062.  
  1063. 200   CALL WDINIT
  1064.  
  1065.       NDATA = 0
  1066.       CALL SNDACK(DATA,NDATA,NSEQ)
  1067.       GO TO 900
  1068.  
  1069. 800   ISTAT = -1
  1070.       STATE = 'A'
  1071.       RETURN
  1072.  
  1073. 900   ISTAT = 0
  1074.       STATE = 'D'
  1075.       RETURN
  1076.       END
  1077.  
  1078.       SUBROUTINE RDATA(STATE,MXDATA,DATA,NDATA,NSEQ)
  1079. C---
  1080. C--- GOT DATA PACKET, WRITE TO FILE
  1081. C---
  1082.       CHARACTER         STATE*1
  1083.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ
  1084.  
  1085.       INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  1086.       COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  1087.  
  1088.       INTEGER           CTL
  1089.       INTEGER           IDATA,NEWCHR
  1090.  
  1091.       IF (STATE .NE. 'D') THEN
  1092.          CALL SNDERR('not expecting D packet',MXDATA,DATA,NSEQ)
  1093.          GO TO 800
  1094.       END IF
  1095.  
  1096. C     UNPACK DATA AND WRITE TO FILE
  1097.  
  1098.       IDATA = 0
  1099.  
  1100. C     EXTRACT NEXT CHARACTER OF DATA FROM PACKET
  1101. 100   IF (IDATA .GE. NDATA) GO TO 200
  1102.       IDATA = IDATA + 1
  1103.       NEWCHR = DATA(IDATA)
  1104.  
  1105.       IF (NEWCHR .EQ. NSQUOT) THEN  ! UNCONTROLLIFY QUOTED CHARACTER
  1106.          IF (IDATA .LT. NDATA) THEN
  1107.             IDATA = IDATA + 1
  1108.             NEWCHR = DATA(IDATA)
  1109.             IF (NEWCHR .NE. NSQUOT) NEWCHR = CTL( NEWCHR )
  1110.          END IF
  1111.       END IF
  1112.  
  1113. C     TRANSFER IT TO THE DISK FILE
  1114.       CALL WDISK(NEWCHR)
  1115.       GO TO 100
  1116.  
  1117. 200   NDATA = 0
  1118.       CALL SNDACK(DATA,NDATA,NSEQ)
  1119.       GO TO 900
  1120.  
  1121. 800   STATE = 'A'
  1122.       RETURN
  1123.  
  1124. 900   STATE = 'D'
  1125.       RETURN
  1126.       END
  1127.  
  1128.       SUBROUTINE REOF(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT)
  1129. C---
  1130. C--- GOT EOF PACKET, CLOSE FILE
  1131. C---
  1132.       CHARACTER         STATE*1
  1133.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT
  1134.  
  1135.       IF (STATE .EQ. 'F') GO TO 100
  1136.       IF (STATE .NE. 'D') THEN
  1137.          CALL SNDERR('not expecting Z packet',MXDATA,DATA,NSEQ)
  1138.          GO TO 800
  1139.       END IF
  1140.  
  1141. C     HANDLE SPECIAL Z PACKET INSTRUCTING US TO DISCARD CURRENT FILE
  1142.       IF (NDATA .EQ. 1 .AND. DATA(1) .EQ. ICHAR('D') ) THEN
  1143.          CALL DELFIL
  1144.  
  1145.       ELSE
  1146.          CALL WDCLOS
  1147.          WRITE (*,*) '=RECEIVE OF CURRENT FILE COMPLETE='
  1148.       END IF
  1149.  
  1150. 100   NDATA = 0
  1151.       CALL SNDACK(DATA,NDATA,NSEQ)
  1152.       GO TO 900
  1153.  
  1154. 800   ISTAT = -1
  1155.       STATE = 'A'
  1156.       RETURN
  1157.  
  1158. 900   ISTAT = 0
  1159.       STATE = 'F'
  1160.       RETURN
  1161.       END
  1162.  
  1163.       SUBROUTINE RBREAK(STATE,MXDATA,DATA,NDATA,NSEQ)
  1164. C---
  1165. C--- GOT BREAK PACKET, WE'RE DONE
  1166. C---
  1167.       CHARACTER         STATE*1
  1168.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ
  1169.  
  1170.       IF (STATE .NE. 'F') THEN
  1171.          CALL SNDERR('not expecting B packet',MXDATA,DATA,NSEQ)
  1172.          GO TO 800
  1173.       END IF
  1174.  
  1175.       NDATA = 0
  1176.       CALL SNDACK(DATA,NDATA,NSEQ)
  1177.       GO TO 900
  1178.  
  1179. 800   STATE = 'A'
  1180.       RETURN
  1181.  
  1182. 900   STATE = 'C'
  1183.       RETURN
  1184.       END
  1185.  
  1186.       SUBROUTINE WDISK(NEWCHR)
  1187. C---
  1188. C--- WRITES A CHARACTER TO A DISK FILE
  1189. C---
  1190. C--- ENTRY POINT "WDINIT" INITIALIZES
  1191. C--- ENTRY POINT "WDCLOS" FINISHES
  1192. C---
  1193.       INTEGER           NEWCHR
  1194.  
  1195.       LOGICAL           DEBUG
  1196.       COMMON /DBGCOM/   DEBUG
  1197.  
  1198.       INTEGER    MAXW,MAXC
  1199.       PARAMETER (MAXW=100, MAXC=3*MAXW)
  1200.       INTEGER           BUFW(MAXW)
  1201.       INTEGER*1         BUFC(MAXC)
  1202.       EQUIVALENCE (BUFW,BUFC)
  1203.  
  1204.       INTEGER           NBUF,CR,LF,I
  1205.       SAVE              BUFW,NBUF
  1206.  
  1207.       DATA CR, LF /13, 10/
  1208.  
  1209.       IF (NEWCHR .EQ. CR) THEN
  1210. C        WRITE COMPLETED RECORD
  1211.          CALL ENPAD(BUFC,NBUF)
  1212.          WRITE (50,'(100A3)') (BUFW(I), I=1,NBUF/3)
  1213.          NBUF = 0
  1214.  
  1215.       ELSE IF (NEWCHR .EQ. LF .AND. NBUF .EQ. 0) THEN
  1216. C        IGNORE LINEFEED FROM A CR/LF PAIR
  1217.  
  1218.       ELSE
  1219. C        ADD CHARACTER TO RECORD BUFFER
  1220.          NBUF = NBUF + 1
  1221.          BUFC(NBUF) = NEWCHR
  1222.       END IF
  1223.       RETURN
  1224.  
  1225. C---
  1226. C--- INITIALIZE CHARACTER COUNT
  1227. C---
  1228.       ENTRY WDINIT()
  1229.  
  1230.       NBUF = 0
  1231.       RETURN
  1232.  
  1233. C---
  1234. C--- WRITE LAST RECORD IF INCOMPLETE AND CLOSE FILE
  1235. C---
  1236.       ENTRY WDCLOS()
  1237.  
  1238.       IF (NBUF .GT. 0) THEN
  1239.          IF (DEBUG) WRITE (*,*) '*WARNING* NO EOL FOUND ON LAST RECORD'
  1240.          CALL ENPAD(BUFC,NBUF)
  1241.          WRITE (50,'(100A3)') (BUFW(I), I=1,NBUF/3)
  1242.          NBUF = 0
  1243.       END IF
  1244.       CLOSE (UNIT=50)
  1245.       RETURN
  1246.       END
  1247.  
  1248.       SUBROUTINE ENPAD(BUFC,NBUF)
  1249. C---
  1250. C--- PAD OUTPUT RECORD TO WORD BOUNDARY WITH BLANKS
  1251. C---
  1252.       INTEGER*1         BUFC(*)
  1253.       INTEGER           NBUF
  1254.  
  1255.       INTEGER           I
  1256.  
  1257.       FOR I=MOD(NBUF+2,3),1
  1258.          NBUF = NBUF + 1
  1259.          BUFC(NBUF) = ICHAR(' ')
  1260.       END FOR
  1261.       END
  1262.  
  1263.       SUBROUTINE DELFIL
  1264. C---
  1265. C--- ERASE PARTIAL FILE ---NOT IMPLEMENTED YET---
  1266. C---
  1267.       WRITE (*,*) '-CURRENT RECEIVE CANCELLED-'
  1268.       CLOSE (UNIT=50)
  1269.       END
  1270. C REMOTE COMMAND SUBROUTINES
  1271. C
  1272. C     COMMND   -- REMOTE COMMAND HANDLER, CALLS THE FOLLOWING:
  1273. C     HELP     -- SENDS USAGE INFORMATION TO RECEIVING KERMIT
  1274. C     LOGOUT   -- PREPARES TO SIGN THE CURRENT USER OFF THE SYSTEM
  1275. C     FINISH   -- PREPARES TO EXIT KERMIT SERVER
  1276. C     DIRECT   -- SENDS DIRECTORY INFORMATION TO RECEIVING KERMIT
  1277. C     CMDARG   -- EXTRACT A COMMAND ARGUMENT FROM PACKET
  1278. C
  1279. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  1280.  
  1281.       SUBROUTINE COMMND(MXDATA,DATA,NDATA,NSEQ,MAXTRY,ISTAT)
  1282. C---
  1283. C--- MAIN ROUTINE HANDLING REMOTE COMMANDS
  1284. C---
  1285.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ,MAXTRY,ISTAT
  1286.  
  1287.       LOGICAL           DEBUG
  1288.       COMMON /DBGCOM/   DEBUG
  1289.  
  1290.       CHARACTER*1       CMD
  1291.  
  1292. C     GET THE COMMAND
  1293.  
  1294.       IF (NDATA .LE. 0) GO TO 900
  1295.       CMD = CHAR( DATA(1) )
  1296.  
  1297.       IF      (CMD .EQ. 'H') THEN            ! HELP
  1298.          CALL HELP(MAXTRY,MXDATA,DATA)
  1299.  
  1300.       ELSE IF (CMD .EQ. 'L') THEN            ! LOGOUT
  1301.          CALL LOGOUT(MAXTRY,MXDATA,DATA)
  1302.          GO TO 800
  1303.  
  1304.       ELSE IF (CMD .EQ. 'F') THEN            ! FINISH
  1305.          CALL FINISH(MAXTRY,MXDATA,DATA)
  1306.          GO TO 800
  1307.  
  1308.       ELSE IF (CMD .EQ. 'D') THEN            ! DIRECTORY
  1309.          CALL DIRECT(MAXTRY,MXDATA,DATA,NDATA)
  1310.  
  1311.       ELSE
  1312.          CALL SNDERR('remote command not implemented',MXDATA,DATA,NSEQ)
  1313.       END IF
  1314.       GO TO 900
  1315.  
  1316. 800   ISTAT = 1   ! RETURN THEN EXIT PROGRAM
  1317.       RETURN
  1318.  
  1319. 900   ISTAT = 0   ! NORMAL RETURN
  1320.       RETURN
  1321.       END
  1322.  
  1323.       SUBROUTINE HELP(MAXTRY,MXDATA,DATA)
  1324. C---
  1325. C--- SEND FILE CONTAINING USAGE INFORMATION
  1326. C---
  1327.       INTEGER           MAXTRY,MXDATA,DATA(*)
  1328.  
  1329.       CHARACTER         HLPFIL*17
  1330.       INTEGER           NDATA,NSEQ,PREFIX
  1331.  
  1332.       DATA HLPFIL /'2000KERM*HARRIS'/
  1333.  
  1334.       PREFIX = 0
  1335.       CALL PUTDAT(HLPFIL,PREFIX,MXDATA,DATA,NDATA)
  1336.  
  1337.       NSEQ = 0
  1338.       CALL SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
  1339.  
  1340.       RETURN
  1341.       END
  1342.  
  1343.       SUBROUTINE LOGOUT(MAXTRY,MXDATA,DATA)
  1344. C---
  1345. C--- SEND CONFIRMATION MESSAGE AND DO A JOBCNTRL $OFF
  1346. C---
  1347.       INTEGER           MAXTRY,MXDATA,DATA(*)
  1348.  
  1349.       LOGICAL           DEBUG
  1350.       COMMON /DBGCOM/   DEBUG
  1351.  
  1352.       INTEGER           NWORDS
  1353.       PARAMETER (NWORDS=2)
  1354.       INTEGER           VOSCMD(NWORDS)
  1355.  
  1356.       CHARACTER         MSG*80
  1357.       INTEGER           NSEQ,USER(4),PREFIX,NDATA,ISTAT
  1358.  
  1359.       NSEQ = 0
  1360.  
  1361. C     PUT JOBCNTRL $OFF COMMAND IN LFN 0 BUFFER
  1362.  
  1363.       VOSCMD(1) = 3H$OF
  1364.       VOSCMD(2) = 3HF
  1365.  
  1366.       CALL BKSTOR(0,VOSCMD,NWORDS,ISTAT)
  1367.       IF (ISTAT .NE. 0) THEN
  1368.          CALL SNDERR('unable to sign off',MXDATA,DATA,NSEQ)
  1369.          RETURN
  1370.       END IF
  1371.  
  1372.       BACKSPACE (UNIT=0)
  1373.  
  1374. C     COPY LOGOUT MESSAGE INTO DATA ARRAY
  1375.  
  1376.       CALL USERNO( USER )
  1377.       WRITE (MSG,1000) USER
  1378.  1000 FORMAT ('SEE YOU LATER, ',4A3)
  1379.  
  1380.       PREFIX = 1
  1381.       CALL PUTDAT(MSG,PREFIX,MXDATA,DATA,NDATA)
  1382.  
  1383. C     ACK WITH OUR CONFIRMATION MESSAGE
  1384.       CALL SNDACK(DATA,NDATA,NSEQ)
  1385.       END
  1386.  
  1387.       SUBROUTINE FINISH(MAXTRY,MXDATA,DATA)
  1388. C---
  1389. C--- SEND CONFIRMATION MESSAGE AND EXIT PROGRAM
  1390. C---
  1391.       INTEGER           MAXTRY,MXDATA,DATA(*)
  1392.  
  1393.       LOGICAL           DEBUG
  1394.       COMMON /DBGCOM/   DEBUG
  1395.  
  1396.       INTEGER           NSEQ,PREFIX,NDATA
  1397.  
  1398. C     COPY EXIT MESSAGE INTO DATA ARRAY
  1399.       PREFIX = 1
  1400.       CALL PUTDAT('returning to JOBCNTRL',PREFIX,MXDATA,DATA,NDATA)
  1401.  
  1402. C     ACK WITH OUR CONFIRMATION MESSAGE
  1403.       NSEQ = 0
  1404.       CALL SNDACK(DATA,NDATA,NSEQ)
  1405.       END
  1406.  
  1407.       SUBROUTINE DIRECT(MAXTRY,MXDATA,DATA,NDATA)
  1408. C---
  1409. C--- SEND DIRECTORY INFORMATION ABOUT A SINGLE DISK AREA
  1410. C---
  1411.       INTEGER           MAXTRY,MXDATA,DATA(*),NDATA
  1412.  
  1413.       CHARACTER         DIRFIL*17, AREANM*19, ERRMSG*80
  1414.       LOGICAL           SIZEORD
  1415.       INTEGER           LFN,NSEQ,ICOL,NARGC,PREFIX,ISTAT,I
  1416.  
  1417.       DATA DIRFIL /'W1'/
  1418.       DATA LFN /99/
  1419.  
  1420. C     GET FILE NAME, OPTIONALLY CONTAINING WILDCARD CHARACTERS
  1421.  
  1422.       IF (NDATA .EQ. 1) THEN
  1423.          NARGC = 0
  1424.       ELSE
  1425.          ICOL = 2
  1426.          CALL CMDARG(ICOL, DATA,NDATA, DATA,NARGC, ISTAT)
  1427.          IF (ISTAT .NE. 0) GO TO 820
  1428.       END IF
  1429.  
  1430.       NARGC = MIN( NARGC, LEN(AREANM) )
  1431.  
  1432.       AREANM = ' '
  1433.       FOR I=1,NARGC
  1434.          AREANM(I:I) = CHAR( DATA(I) )
  1435.       END FOR
  1436.  
  1437. C     OPEN A DIRECTORY WORKFILE
  1438.  
  1439.       OPEN (UNIT=LFN, FILE=DIRFIL, STATUS='OLD', IOSTAT=ISTAT)
  1440.       IF (ISTAT .NE. 0) GO TO 810
  1441.  
  1442.       REWIND (UNIT=LFN)
  1443.  
  1444. C     WRITE DIRECTORY INFORMATION TO THE WORKFILE
  1445.  
  1446.       SIZEORD  = .FALSE.
  1447.  
  1448.       CALL DIR(LFN,AREANM,NARGC,SIZEORD,ERRMSG,ISTAT)
  1449.       IF (ISTAT .NE. 0) GO TO 800
  1450.  
  1451.       CLOSE (UNIT=LFN)
  1452.  
  1453. C     INVOKE THE SEND SWITCHER TO SEND THE WORKFILE
  1454.  
  1455.       PREFIX = 0
  1456.       CALL PUTDAT(DIRFIL,PREFIX,MXDATA,DATA,NDATA)
  1457.  
  1458.       NSEQ = 0
  1459.       CALL SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY)
  1460.       GO TO 900
  1461.  
  1462. 800   CALL SNDERR(ERRMSG,MXDATA,DATA,NSEQ)
  1463.       RETURN
  1464.  
  1465. 810   CALL SNDERR('directory workfile inaccessable',MXDATA,DATA,NSEQ)
  1466.       RETURN
  1467.  
  1468. 820   CALL SNDERR('invalid command format',MXDATA,DATA,NSEQ)
  1469.       RETURN
  1470.  
  1471. 900   RETURN
  1472.       END
  1473.  
  1474.       SUBROUTINE CMDARG(ICOL, DATA,NDATA, ARG,NARGC, ISTAT)
  1475. C---
  1476. C--- EXTRACT A LENGTH-ENCODED ARGUMENT FROM DATA FIELD
  1477. C---
  1478.       INTEGER           ICOL,DATA(*),NDATA,ARG(*),NARGC,ISTAT
  1479.  
  1480.       INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  1481.       COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  1482.  
  1483.       INTEGER           CTL,UNCHAR
  1484.       INTEGER           IDATA,IARGC,NEWCHR
  1485.  
  1486. C     READ STARTING AT CHARACTER POSITION <ICOL> IN ARRAY <DATA>
  1487.  
  1488.       NARGC = 0
  1489.       IDATA = ICOL
  1490.  
  1491. C     GET NEXT CHARACTER FROM <DATA>, UNCONTROLLIFYING AS NECESSARY
  1492.  
  1493. 100   IF (IDATA .GT. NDATA) GO TO 800
  1494.  
  1495.       NEWCHR = DATA(IDATA)
  1496.       IDATA = IDATA + 1
  1497.  
  1498.       IF (NEWCHR .EQ. NSQUOT) THEN
  1499.          IF (IDATA .GT. NDATA) GO TO 800
  1500.          NEWCHR = DATA(IDATA)
  1501.          IDATA = IDATA + 1
  1502.          IF (NEWCHR .NE. NSQUOT) NEWCHR = CTL( NEWCHR )
  1503.       END IF
  1504.  
  1505. C     CONVERT TO UPPER CASE
  1506.  
  1507.       IF (NEWCHR .GT. ICHAR('a') .AND. NEWCHR .LT. ICHAR('z') ) THEN
  1508.          NEWCHR = NEWCHR - ICHAR('a') + ICHAR('A')
  1509.       END IF
  1510.  
  1511. C     FIRST CHARACTER IS LENGTH CODE
  1512.  
  1513.       IF (NARGC .EQ. 0) THEN
  1514.          IARGC = 0
  1515.          NARGC = UNCHAR( NEWCHR )
  1516.  
  1517. C     COPY SUBSEQUENT CHARACTERS TO <ARG>
  1518.  
  1519.       ELSE
  1520.          IARGC = IARGC + 1
  1521.          ARG(IARGC) = NEWCHR
  1522.       END IF
  1523.  
  1524. C     RETURN THE RESULT OF LENGTH <NARGC> IN ARRAY <ARG>
  1525.  
  1526.       IF (IARGC .GE. NARGC) THEN
  1527.          IF (IDATA .GT. NDATA) GO TO 900
  1528.          GO TO 810
  1529.       END IF
  1530.  
  1531.       GO TO 100
  1532.  
  1533. 800   ISTAT = -1  ! CAN'T DECODE ARGUMENT (INVALID LENGTH CODE)
  1534.       RETURN
  1535.  
  1536. 810   ISTAT = 1   ! SUCCESSFUL RETURN, MORE ARGUMENTS REMAIN
  1537.       RETURN
  1538.  
  1539. 900   ISTAT = 0   ! SUCCESSFUL RETURN, THIS IS LAST ARGUMENT
  1540.       RETURN
  1541.       END
  1542.       SUBROUTINE DIR(LFN,AREANM,NC,SIZEORD,ERRMSG,ISTAT)
  1543. C
  1544. C CHECKS ALL AREANAMES AGAINST MATCH STRING, SAVING NECESSARY INFO
  1545. C ON THOSE WHICH MATCH IN COMMON.  WRITES RESULTS TO SPECIFIED LFN.
  1546. C
  1547. C ARGUMENTS:
  1548. C     LFN     -- LOGICAL UNIT TO WRITE RESULTS
  1549. C     AREANM  -- INPUT AREANAME, OPTIONALLY CONTAINING WILDCARDS
  1550. C     NC      -- NUMBER OF CHARACTERS IN AREANM
  1551. C     SIZEORD -- LOGICAL VARIABLE INDICATING ORDER BY SIZE IF TRUE
  1552. C     ERRMSG  -- TEXT STRING IDENTIFYING ERROR IF ISTAT NON-ZERO
  1553. C     ISTAT   -- ZERO=SUCCESSFUL COMPLETION; NON-ZERO=ERROR
  1554. C
  1555.       INTEGER     LFN, NC, ISTAT
  1556.       CHARACTER   AREANM*(*), ERRMSG*(*)
  1557.       LOGICAL     SIZEORD
  1558. C
  1559.       INTEGER     MXMAP
  1560.       PARAMETER (MXMAP=999)
  1561.       CHARACTER   NAME*17, TYPE*3, RWXD*11, OWNER*12
  1562.       INTEGER     SIZE, GRAN, NLINK, NFILES, IFIRST
  1563.       INTEGER     MAXS, EL(6),GE(6),LA(6),LW(6)
  1564.       COMMON /MAPDAT/ NAME(MXMAP), TYPE(MXMAP), RWXD(MXMAP),
  1565.      +  OWNER(MXMAP), SIZE(MXMAP), NLINK(MXMAP), NFILES, IFIRST
  1566. C
  1567.       INTEGER     NTOT, IPREV, INEXT
  1568.       INTEGER     NCHARS, ISTAR, IWILD, I
  1569.       REAL        KBYTES
  1570. C
  1571. C INITIALIZE FILE LIST
  1572. C
  1573.       NFILES = 0
  1574.       IFIRST = 0
  1575.  
  1576.       NTOT = 0
  1577. C
  1578. C PARSE MATCH STRING TO DETERMINE IF MORE THAN ONE AREANAME IS INVOLVED
  1579. C
  1580.       NCHARS = 0
  1581.       ISTAR = 0
  1582.       IWILD = 0
  1583.  
  1584.       FOR I=1,NC                       ! FIND SPECIAL CHARACTERS
  1585.          IF (AREANM(I:I) .NE. ' ') THEN
  1586.             NCHARS = I
  1587.             IF (AREANM(I:I) .EQ. '*') ISTAR = I
  1588.             IF (IWILD .EQ. 0 .AND.
  1589.      +          AREANM(I:I) .EQ. '?') IWILD = I
  1590.          END IF
  1591.       END FOR
  1592.  
  1593.       IF (ISTAR .EQ. NCHARS) THEN      ! DEFAULT AREANAME IS ?
  1594.          NCHARS = NCHARS + 1
  1595.          AREANM(NCHARS:NCHARS) = '?'
  1596.          IF (IWILD .EQ. 0) IWILD = I
  1597.       END IF
  1598. C
  1599. C IF ONLY A SINGLE AREANAME IS INDICATED, DO IT NOW
  1600. C
  1601.       IF (IWILD .EQ. 0) THEN
  1602.  
  1603.          CALL MAP(AREANM,
  1604.      +         NAME(1),TYPE(1),RWXD(1),SIZE(1),GRAN,MAXS,OWNER(1),
  1605.      +         EL,GE,LA,LW, ISTAT)
  1606.          IF (ISTAT .EQ. 0) THEN
  1607.             KBYTES = SIZE(1) * 336.0 / 1024.0
  1608.             WRITE (LFN,1100) NAME(1),OWNER(1),TYPE(1),RWXD(1),KBYTES,
  1609.      +                       GE,LW,LA
  1610.  1100 FORMAT (7X,A, T40,'OWNER: ',A,
  1611.      +       /'TYPE: ',A, 7X,'ACCESS: 'A, T40,'SIZE (KBYTES):',F7.1,
  1612.      +       /'CREATED:        ', 6A3,
  1613.      +       /'LAST UPDATED:   ', 6A3,
  1614.      +       /'LAST ACCESSED:  ', 6A3)
  1615.             GO TO 900
  1616.          ELSE
  1617.             ERRMSG = '*disc area not found*'
  1618.             GO TO 800
  1619.          END IF
  1620.       END IF
  1621. C
  1622. C MAKE SURE THEY DIDN'T WILDCARD ONLY PART OF THE QUALIFIER
  1623. C
  1624.       IF (IWILD .LT. ISTAR .AND. ISTAR .NE. 2) THEN
  1625.          ERRMSG =
  1626.      +      '*error* invalid qualifier, use "?*" for all qualifiers'
  1627.          GO TO 800
  1628.       END IF
  1629. C
  1630. C INITIALIZE THE CALL TO MAPWILD
  1631. C
  1632.       CALL MAPINIT(AREANM(1:NCHARS),ISTAT)
  1633.       IF (ISTAT .NE. 0) THEN
  1634.          ERRMSG = '*error* invalid qualifier or areaname'
  1635.          GO TO 800
  1636.       END IF
  1637. C
  1638. C LOOP THROUGH ALL FILES
  1639. C
  1640.       NTOT = 0
  1641.  
  1642.       LOOP
  1643.  
  1644.          I = NFILES + 1
  1645.          CALL MAPWILD(
  1646.      +         NAME(I),TYPE(I),RWXD(I),SIZE(I),GRAN,MAXS,OWNER(I),
  1647.      +         EL,GE,LA,LW, ISTAT)
  1648.  
  1649.          IF (ISTAT .LT. 0) THEN
  1650.             EXIT LOOP IF (ISTAT .EQ. -2)
  1651.             WRITE (LFN,*) '*error*  disc I/O error mapping file'
  1652.             GO TO 300
  1653.          END IF
  1654. C
  1655. C IF IT MATCHED, LINK INTO THE LIST IN SORTED ORDER
  1656. C
  1657.          NTOT = NTOT + 1
  1658.          IF (ISTAT .NE. 0) GO TO 200
  1659.  
  1660.          NFILES = I
  1661.  
  1662.          IPREV = 0
  1663.          INEXT = IFIRST
  1664.          WHILE (INEXT .GT. 0)
  1665.             IF (SIZEORD) THEN          ! ORDER BY SIZE
  1666.                EXIT WHILE IF ( SIZE(INEXT) .GT. SIZE(NFILES) )
  1667.                EXIT WHILE IF ( SIZE(INEXT) .EQ. SIZE(NFILES)
  1668.      +                   .AND. NAME(INEXT) .GE. NAME(NFILES) )
  1669.             ELSE                       ! ORDER BY NAME
  1670.                EXIT WHILE IF (NAME(INEXT) .GE. NAME(NFILES))
  1671.             END IF
  1672.             IPREV = INEXT
  1673.             INEXT = NLINK(INEXT)
  1674.          END WHILE
  1675.  
  1676. C        WE FOUND WHERE IT GOES, NOW LINK IT IN
  1677.          IF (IPREV .LE. 0) THEN        ! INSERT AT ROOT OF LIST
  1678.             NLINK(NFILES) = IFIRST
  1679.             IFIRST = NFILES
  1680.          ELSE                          ! INSERT INTO LIST
  1681.             NLINK(NFILES) = INEXT
  1682.             NLINK(IPREV) = NFILES
  1683.          END IF
  1684.  
  1685. 200      CONTINUE
  1686.  
  1687. 300   END LOOP
  1688. C
  1689. C WRITE SORTED RESULTS TO SPECIFIED UNIT
  1690. C
  1691.       IF (NFILES .LT. 1) THEN
  1692.          ERRMSG = '*disc area not found*'
  1693.          GO TO 800
  1694.       END IF
  1695.  
  1696.       WRITE (LFN,1500)
  1697.  
  1698.       I = IFIRST
  1699.       WHILE (I .GT. 0)
  1700.          KBYTES = SIZE(I) * 336.0 / 1024.0
  1701.          WRITE (LFN,1510) NAME(I),TYPE(I),RWXD(I),KBYTES,OWNER(I)
  1702.          I = NLINK(I)
  1703.       END WHILE
  1704.  
  1705.       IF (NTOT .GT. NFILES) WRITE (LFN,1520) NFILES, NTOT
  1706.  
  1707.  1500 FORMAT (4X,'AREANAME', 7X,'TYPE', 4X,'ACCESS',
  1708.      +        6X,'KBYTES', 4X,'OWNER')
  1709.  1510 FORMAT (A, 2X,A, 3X,A, F8.1, 5X,A)
  1710.  1520 FORMAT (/I4, ' files matched of', I5)
  1711.       GO TO 900
  1712.  
  1713. 800   ISTAT = -1
  1714.       RETURN
  1715.  
  1716. 900   ISTAT = 0
  1717.       RETURN
  1718.       END
  1719.  
  1720.       INTEGER FUNCTION ICOMP(MATCH,NM,STRING,NS)
  1721. C
  1722. C COMPARES A MATCH STRING, CONTAINING WILDCARD CHARACTERS, WITH AN
  1723. C OBJECT STRING.  RETURNS 0 IF MATCH SUCCEDED, 1 OTHERWISE
  1724. C
  1725.       CHARACTER      MATCH, STRING     ! MATCH AND COMPARE STRINGS
  1726.       INTEGER        NM, NS            ! LENGTHS OF ABOVE
  1727. C
  1728.       CHARACTER      C*1               ! CURRENT MATCH CHARACTER
  1729.       LOGICAL        AT                ! SET IF LAST CHARACTER WAS ?
  1730.       INTEGER        M                 ! MATCH STRING POINTER
  1731.       INTEGER        S                 ! COMPARE STRING POINTER
  1732.       INTEGER        LM                ! POINTER TO LAST ? PROCESSED
  1733.       INTEGER        LS                ! S AFTER LAST ?
  1734.       INTEGER        J
  1735. C
  1736. C INITIALIZE
  1737. C
  1738.       ICOMP = 1                        ! ASSUME NO MATCH
  1739.  
  1740.       M  = 1
  1741.       S  = 1
  1742.       LM = 0
  1743.       LS = 0
  1744.       AT = .FALSE.
  1745. C
  1746. C LOOP THROUGH MATCH CHARACTERS
  1747. C
  1748. 10    WHILE (M .LE. NM)
  1749.          C = MATCH(M:M)                ! GET CURRENT MATCH CHARACTER
  1750. C
  1751. C       HANDLE ? CHARACTER
  1752. C
  1753.          IF (C .EQ. '?') THEN
  1754.             AT = .TRUE.
  1755.             LM = M
  1756. C
  1757. C       HANDLE OTHER CHARACTERS
  1758. C
  1759.          ELSE
  1760.             IF (S .GT. NS) RETURN      ! NO MORE CHARS IN SUBSTRING
  1761.             IF (AT) THEN               ! SKIP UNKNOWN CHARACTERS
  1762.                J = INDEX(STRING(S:NS),C)
  1763.                IF (J .EQ. 0) RETURN
  1764.                S = S + J
  1765.                LS = S
  1766.                AT = .FALSE.
  1767.             ELSE                       ! CHECK FOR EXACT MATCH
  1768.                IF (C .EQ. STRING(S:S)) THEN
  1769.                   S = S + 1
  1770.                ELSE                    ! NO MATCH
  1771.                   IF (LS .GT. 0) THEN
  1772.                      M = LM
  1773.                      S = LS
  1774.                      GO TO 10          ! BACK UP TO ?+1 AND TRY AGAIN
  1775.                   ELSE
  1776.                      RETURN
  1777.                   END IF
  1778.                END IF
  1779.             END IF
  1780.          END IF
  1781.          M = M + 1
  1782.       END WHILE
  1783. C
  1784. C MAKE SURE ANY REMAINING CHARACTERS IN STRING ARE TRAILING BLANKS
  1785. C
  1786.       IF (.NOT. AT) THEN
  1787.          IF (S .LE. NS) THEN
  1788.             IF (STRING(S:NS) .NE. ' ') THEN
  1789.                M = LM
  1790.                S = LS
  1791.                GO TO 10                ! BACK UP TO ?+1 AND TRY AGAIN
  1792.             END IF
  1793.          END IF
  1794.       END IF
  1795.  
  1796.       ICOMP = 0                        ! SUCCESSFUL MATCH
  1797.  
  1798.       END
  1799.  
  1800.       SUBROUTINE MAPINIT(AREANM,ISTAT),
  1801.      +           MAPWILD(NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
  1802.      +                   ELDATE,GEDATE,LADATE,LWDATE,ISTAT)
  1803. C
  1804. C     MAPWILD                                    FORTRAN 77 / ASSEMBLER
  1805. C     WRITTEN BY SKIP RUSSELL                          APRIL, 1983
  1806. C
  1807. C     SUBROUTINE TO RETURN INFORMATION ABOUT ALL DISK AREAS WHICH
  1808. C     SUCCESSFULLY MATCH A "WILDCARD" AREANAME STRING.
  1809. C
  1810. C     THE QUALIFIER OF THE MATCH STRING, IF SPECIFIED, DETERMINES
  1811. C     THE MAPPING OPERATION TO PERFORM AS FOLLOWS:
  1812. C
  1813. C     NO QUALIFIER SPECIFIED -- SEARCH FILES UNDER CURRENT QUALIFIER
  1814. C     VALID QUALIFIER        -- SEARCH FILES UNDER SPECIFIED QUALIFIER
  1815. C     QUALIFIER = "?"        -- SEARCH ALL FILES OWNED BY CURRENT USER
  1816. C
  1817. C
  1818. C MAPINIT: (INITIALIZATION FOR MAPWILD)
  1819. C     INPUT ARGUMENTS:
  1820. C        AREANM -- AREA NAME TO MATCH CONTAINING WILDCARD CHARACTERS
  1821. C        ISTAT  -- STATUS INDICATOR, AS FOLLOWS:
  1822. C                     0 = SUCCESSFUL
  1823. C                    -1 = INVALID NAME
  1824. C
  1825. C MAPWILD:
  1826. C     OUTPUT ARGUMENTS:
  1827. C        NAME   -- QUAL*AREA                        (CHARACTER*17)
  1828. C        TYPE   -- PROGRAM TYPE                     (CHARACTER*3)
  1829. C        RWXD   -- READ/WRITE/EXECUTE/DELETE ACCESS (CHARACTER*11)
  1830. C        SIZE   -- CURRENT SIZE IN SECTORS          (INTEGER)
  1831. C        GRAN   -- GRANULE SIZE IN SECTORS          (INTEGER)
  1832. C        MAXS   -- MAXIMUM SIZE IN SECTORS          (INTEGER)
  1833. C        OWNER  -- USER NAME OF THE OWNER           (CHARACTER*12)
  1834. C        ELDATE -- ELIMINATE DATE/TIME              (6 INTEGER ARRAY)
  1835. C        GEDATE -- GENERATE DATE/TIME               (6 INTEGER ARRAY)
  1836. C        LADATE -- LAST ACCESS DATE/TIME            (6 INTEGER ARRAY)
  1837. C        LWDATE -- LAST WRITE DATE/TIME             (6 INTEGER ARRAY)
  1838. C        ISTAT  -- STATUS INDICATOR, AS FOLLOWS:
  1839. C                     0 = MAP INFORMATION RETURNED AS REQUESTED
  1840. C                    +1 = FILE NAME DOES NOT MATCH GIVEN MATCH STRING
  1841. C                    -1 = ERROR (E.G. READ ERROR OR UNRESOURCED PACK)
  1842. C                    -2 = NO MORE FILES
  1843. C
  1844. C ---------------------------------------------------------------------
  1845.  
  1846.       CHARACTER   AREANM*(*)      ! AREANAME MATCH STRING
  1847. C
  1848.       CHARACTER   NAME*17         ! AREANAME
  1849.       CHARACTER   TYPE*3          ! FILE TYPE
  1850.       CHARACTER   RWXD*11         ! ACCESS CODE
  1851.       INTEGER     SIZE            ! CURRENT SIZE
  1852.       INTEGER     GRAN            ! GRANULE SIZE
  1853.       INTEGER     MAXS            ! MAXIMUM SIZE
  1854.       CHARACTER   OWNER*12        ! OWNER'S NAME
  1855.       INTEGER     ELDATE(6)       ! PURGE DATE/TIME
  1856.       INTEGER     GEDATE(6)       ! GENERATION D/T
  1857.       INTEGER     LADATE(6)       ! LAST REFERENCE D/T
  1858.       INTEGER     LWDATE(6)       ! LAST WRITE D/T
  1859.       INTEGER     ISTAT           ! MAP STATUS RETURNED
  1860. C
  1861.       INTEGER     PARLST(5)       ! PARAMETER LIST FOR $DASAVE
  1862.       INTEGER     DAIB(24,9)      ! DISC AREA INFORMATION BLOCK
  1863.       EQUIVALENCE (PARLST(5),DAIB)
  1864. C
  1865.       CHARACTER   NAMTMP*19       ! TEMPORARY AREANAME
  1866.       INTEGER     NAMEQV(7)       ! HOLLERITH FORM OF AREANAME
  1867.       EQUIVALENCE (NAMTMP,NAMEQV)
  1868. C
  1869.       CHARACTER   MATCH*15        ! AREANAME PORTION OF MATCH STRING
  1870.       INTEGER     NCHARS,ISTAR    ! CHARACTER POINTERS
  1871.       INTEGER     NMATCH,I        ! CHARACTER POINTERS
  1872.       INTEGER     MODE            ! SEARCH FUNCTION TO PERFORM
  1873.       INTEGER     NWORDS, FILENO  ! BUFFER POINTERS
  1874.       INTEGER     ICOMP, JCOMP    ! COMPARISON FUNCTION, RESULT
  1875.       DATA FILENO / -1 /
  1876. C
  1877. C GET QUALIFIER IN TRUNCATED ASCII, IF REQUIRED
  1878. C
  1879.       ISTAR = 0
  1880.       FOR I=1,LEN(AREANM)
  1881. C        FIND QUALIFIER DELIMITER
  1882.          IF (AREANM(I:I) .EQ. '*') THEN
  1883.             ISTAR = I
  1884.             EXIT FOR
  1885.          END IF
  1886.       END FOR
  1887.  
  1888. C     HANDLE A WILDCARD QUALIFIER
  1889.       IF (ISTAR .EQ. 2 .AND. AREANM(1:1) .EQ. '?') THEN
  1890.          MODE = 2
  1891.  
  1892.       ELSE
  1893.          MODE = 1
  1894. C        ASSEMBLE A DUMMY AREANAME USING THE SPECIFED QUALIFIER
  1895.          IF (ISTAR .LE. 0) THEN
  1896.             NAMTMP = 'TEMPNAME'
  1897.          ELSE
  1898.             NAMTMP = AREANM(1:ISTAR) // 'TEMPNAME'
  1899.          END IF
  1900.  
  1901.          CALL FILNAM(NAMTMP,PARLST,ISTAT)
  1902.          IF (ISTAT .LE. 0) GO TO 800
  1903.       END IF
  1904. C
  1905. C MAKE  A COPY OF THE MATCH STRING
  1906. C
  1907.       MATCH = AREANM(ISTAR+1:)
  1908.       NMATCH = LEN(AREANM) - ISTAR
  1909. C
  1910. C PERFORM INITIAL CALL TO $DASAVE
  1911. C
  1912.       IF (MODE .EQ. 1) THEN            ! SINGLE QUALIFIER
  1913. :ASSEM
  1914.         REEN                 MAKE THE ROUTINE RE-ENTRANT
  1915. *
  1916.         TLO   PARLST         DEFINE PARAMETER LIST
  1917.         BLU   $DASAVE        GET THE DISK INFO
  1918.         DATA  2              FUNCTION CODE FOR GET ALL FILES FROM QUAL
  1919.         CZA                  ERROR?
  1920.         BNZ   $800           YES, EXIT
  1921.         TEM   NWORDS         NO, GET WORD COUNT
  1922. :END
  1923.       ELSE                             ! ALL QUALIFIERS
  1924. :ASSEM
  1925.         TLO   PARLST         DEFINE PARAMETER LIST
  1926.         BLU   $DASAVE        GET THE DISK INFO
  1927.         DATA  8              FUNCTION CODE FOR GET ALL USER FILES
  1928.         CZA                  ERROR?
  1929.         BNZ   $800           YES, EXIT
  1930.         TEM   NWORDS         NO, GET WORD COUNT
  1931. :END
  1932.       END IF
  1933.  
  1934.       FILENO = 1                       ! INDICATE FIRST FILE
  1935.       GO TO 900
  1936. C
  1937. C ---------------------------------------------------------------------
  1938. C
  1939.       ENTRY MAPWILD
  1940.  
  1941.       IF (FILENO .LE. 0) STOP '*error* MAPWILD not initialized'
  1942.       IF (NWORDS .LE. 0) GO TO 810     ! NO MORE FILES
  1943. C
  1944. C MAKE SURE THE CURRENT FILE MATCHES BEFORE WE PROCESS IT
  1945. C
  1946.       CALL TATOA(DAIB(13,FILENO),NAMEQV(1),8)  ! QUALIFIER
  1947.       CALL TATOA(DAIB( 1,FILENO),NAMEQV(4),8)  ! AREANAME
  1948.       NAMTMP(9:9) = '*'
  1949.       NAME = NAMTMP
  1950.  
  1951.       JCOMP = ICOMP( MATCH,NMATCH, NAME(10:17),8 )
  1952.       IF (JCOMP .EQ. 0) THEN
  1953.          CALL MAPIFY( DAIB(1,FILENO),
  1954.      +         NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
  1955.      +         ELDATE,GEDATE,LADATE,LWDATE )
  1956.       END IF
  1957. C
  1958. C INCREMENT THE BUFFER POINTER
  1959. C
  1960.       FILENO = FILENO + 1
  1961.       NWORDS = NWORDS - 24
  1962. C
  1963. C IF THE CURRENT BUFFER IS EMPTY, GET INFORMATION ON UP TO 9 MORE FILES
  1964. C
  1965.       IF (NWORDS .EQ. 0) THEN
  1966. :ASSEM
  1967.         TLO   PARLST         DEFINE PARAMETER LIST
  1968.         BLU   $DASAVE        GET THE DISK INFO
  1969.         DATA  0              FUNCTION CODE FOR GET INFO
  1970.         CZA                  ERROR?
  1971.         BNZ   $800           YES, EXIT
  1972.         TEM   NWORDS         NO, GET NEW WORD COUNT
  1973. :END
  1974.          FILENO = 1                    ! INDICATE FIRST FILE
  1975.       END IF
  1976.  
  1977.       IF (JCOMP .NE. 0) GO TO 820
  1978.       GO TO 900
  1979. C
  1980. C ERROR
  1981. C
  1982. 800   ISTAT = -1
  1983.       RETURN
  1984. C
  1985. C NO MORE FILES
  1986. C
  1987. 810   ISTAT = -2
  1988.       RETURN
  1989. C
  1990. C COMPARISON WITH MATCH STRING FAILED (ONLY QUAL*NAME RETURNED)
  1991. C
  1992. 820   ISTAT = 1
  1993.       RETURN
  1994. C
  1995. C SUCCESSFUL RETURN
  1996. C
  1997. 900   ISTAT = 0
  1998.       RETURN
  1999.       END
  2000.  
  2001.       SUBROUTINE MAP(AREANM, NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
  2002.      +                       ELDATE,GEDATE,LADATE,LWDATE,ISTAT)
  2003. C
  2004. C     MAPFILE                                    FORTRAN 77 / ASSEMBLER
  2005. C     WRITTEN BY SKIP RUSSELL                          APRIL, 1983
  2006. C
  2007. C     SUBROUTINE TO RETURN DIRECTORY INFORMATION ON A SINGLE DISK AREA
  2008. C
  2009. C
  2010. C     INPUT ARGUMENTS:
  2011. C        AREANM -- AREA NAME TO MATCH               (CHARACTER STRING)
  2012. C
  2013. C     OUTPUT ARGUMENTS:
  2014. C        NAME   -- QUAL*AREA                        (CHARACTER*17)
  2015. C        TYPE   -- PROGRAM TYPE                     (CHARACTER*3)
  2016. C        RWXD   -- READ/WRITE/EXECUTE/DELETE ACCESS (CHARACTER*11)
  2017. C        SIZE   -- CURRENT SIZE IN SECTORS          (INTEGER)
  2018. C        GRAN   -- GRANULE SIZE IN SECTORS          (INTEGER)
  2019. C        MAXS   -- MAXIMUM SIZE IN SECTORS          (INTEGER)
  2020. C        OWNER  -- USER NAME OF THE OWNER           (CHARACTER*12)
  2021. C        ELDATE -- ELIMINATE DATE/TIME              (6 INTEGER ARRAY)
  2022. C        GEDATE -- GENERATE DATE/TIME               (6 INTEGER ARRAY)
  2023. C        LADATE -- LAST ACCESS DATE/TIME            (6 INTEGER ARRAY)
  2024. C        LWDATE -- LAST WRITE DATE/TIME             (6 INTEGER ARRAY)
  2025. C        ISTAT  -- STATUS INDICATOR, AS FOLLOWS:
  2026. C                    +1 = FILE NOT FOUND
  2027. C                     0 = MAP INFORMATION RETURNED (SUCCESSFUL)
  2028. C                    -1 = INVALID NAME SPECIFIED
  2029. C
  2030. C ---------------------------------------------------------------------
  2031.  
  2032.       CHARACTER   AREANM*(*)      ! AREANAME MATCH STRING
  2033. C
  2034.       CHARACTER   NAME*17         ! AREANAME
  2035.       CHARACTER   TYPE*3          ! FILE TYPE
  2036.       CHARACTER   RWXD*11         ! ACCESS CODE
  2037.       INTEGER     SIZE            ! CURRENT SIZE
  2038.       INTEGER     GRAN            ! GRANULE SIZE
  2039.       INTEGER     MAXS            ! MAXIMUM SIZE
  2040.       CHARACTER   OWNER*12        ! OWNER'S NAME
  2041.       INTEGER     ELDATE(6)       ! PURGE DATE/TIME
  2042.       INTEGER     GEDATE(6)       ! GENERATION D/T
  2043.       INTEGER     LADATE(6)       ! LAST REFERENCE D/T
  2044.       INTEGER     LWDATE(6)       ! LAST WRITE D/T
  2045.       INTEGER     ISTAT           ! MAP STATUS RETURNED
  2046. C
  2047.       INTEGER     PARLST(5)       ! PARAMETER LIST FOR $DASAVE
  2048.       INTEGER     DAIB(24)        ! DISC AREA INFORMATION BLOCK
  2049.       EQUIVALENCE (PARLST(5),DAIB)
  2050. C
  2051. C GET FILE NAME IN TRUNCATED ASCII
  2052. C
  2053.       CALL FILNAM(AREANM,PARLST,ISTAT)
  2054.       IF (ISTAT .LE. 0) GO TO 800
  2055. C
  2056. C CALL $DASAVE SYSTEM SERVICE
  2057. C
  2058. :ASSEM
  2059.         REEN                 MAKE THE ROUTINE RE-ENTRANT
  2060. *
  2061.         TLO   PARLST         DEFINE PARAMETER LIST
  2062.         BLU   $DASAVE        GET THE DISK INFO
  2063.         DATA  7              FUNCTION CODE FOR GET INFO ON ONE FILE
  2064.         CZA                  ERROR?
  2065.         BNZ   $810           YES, EXIT
  2066. :END
  2067. C
  2068. C PROCESS OUTPUT AND RETURN
  2069. C
  2070.       CALL MAPIFY(DAIB, NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
  2071.      +                  ELDATE,GEDATE,LADATE,LWDATE)
  2072.       GO TO 900
  2073. C
  2074. C INVALID FILE NAME
  2075. C
  2076. 800   ISTAT = -1
  2077.       RETURN
  2078. C
  2079. C FILE NOT FOUND
  2080. C
  2081. 810   ISTAT = 1
  2082.       RETURN
  2083. C
  2084. C SUCCESSFUL RETURN
  2085. C
  2086. 900   ISTAT = 0
  2087.       RETURN
  2088.       END
  2089.  
  2090.       SUBROUTINE MAPIFY(DAIB, NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER,
  2091.      +                        ELDATE,GEDATE,LADATE,LWDATE)
  2092. C
  2093. C     SUBROUTINE TO DECODE A DISK AREA INFORMATION BLOCK
  2094. C
  2095. C     INPUT ARGUMENT:
  2096. C        DAIB   -- 24 WORD DAIB AS RETURNED BY THE $DASAVE SERVICE
  2097. C
  2098. C     OUTPUT ARGUMENTS:
  2099. C        NAME   -- QUAL*AREA                        (CHARACTER*17)
  2100. C        TYPE   -- PROGRAM TYPE                     (CHARACTER*3)
  2101. C        RWXD   -- READ/WRITE/EXECUTE/DELETE ACCESS (CHARACTER*11)
  2102. C        SIZE   -- CURRENT SIZE IN SECTORS          (INTEGER)
  2103. C        GRAN   -- GRANULE SIZE IN SECTORS          (INTEGER)
  2104. C        MAXS   -- MAXIMUM SIZE IN SECTORS          (INTEGER)
  2105. C        OWNER  -- USER NAME OF THE OWNER           (CHARACTER*12)
  2106. C        ELDATE -- ELIMINATE DATE/TIME              (6 INTEGER ARRAY)
  2107. C        GEDATE -- GENERATE DATE/TIME               (6 INTEGER ARRAY)
  2108. C        LADATE -- LAST ACCESS DATE/TIME            (6 INTEGER ARRAY)
  2109. C        LWDATE -- LAST WRITE DATE/TIME             (6 INTEGER ARRAY)
  2110. C
  2111. C ---------------------------------------------------------------------
  2112.  
  2113.       INTEGER     DAIB(24)        ! DISC AREA INFORMATION BLOCK
  2114. C
  2115.       CHARACTER   NAME*17         ! AREANAME
  2116.       CHARACTER   TYPE*3          ! FILE TYPE
  2117.       CHARACTER   RWXD*11         ! ACCESS CODE
  2118.       INTEGER     SIZE            ! CURRENT SIZE
  2119.       INTEGER     GRAN            ! GRANULE SIZE
  2120.       INTEGER     MAXS            ! MAXIMUM SIZE
  2121.       CHARACTER   OWNER*12        ! OWNER'S NAME
  2122.       INTEGER     ELDATE(6)       ! PURGE DATE/TIME
  2123.       INTEGER     GEDATE(6)       ! GENERATION D/T
  2124.       INTEGER     LADATE(6)       ! LAST REFERENCE D/T
  2125.       INTEGER     LWDATE(6)       ! LAST WRITE D/T
  2126. C
  2127.       CHARACTER   OWNTMP*12       ! TEMPORARY OWNER NAME
  2128.       INTEGER     PARLS2(10)      ! PARAMETER LIST FOR $USERNO
  2129.       EQUIVALENCE (OWNTMP,PARLS2(5))
  2130. C
  2131.       CHARACTER   NAMTMP*18       ! TEMPORARY AREANAME
  2132.       INTEGER     NAMEQV(6)       ! HOLLERITH FORM OF AREANAME
  2133.       EQUIVALENCE (NAMTMP,NAMEQV)
  2134. C
  2135.       CHARACTER   PREFIX*1        ! PUBLIC/ACCOUNT FLAG
  2136.       INTEGER     I
  2137. C
  2138. C     AREANAME
  2139. C
  2140.       CALL TATOA(DAIB(13),NAMEQV(1),8)  ! QUALIFIER
  2141.       CALL TATOA(DAIB( 1),NAMEQV(4),8)  ! AREANAME
  2142.       NAMTMP(9:9) = "*"
  2143.       NAME = NAMTMP
  2144. C
  2145. C     TYPE
  2146. C
  2147.       I = DAIB(8)
  2148.       IF      ((I.AND.'40000000) .NE. 0) THEN
  2149.          TYPE = 'INT'
  2150.       ELSE IF ((I.AND.'10000000) .NE. 0) THEN
  2151.          TYPE = 'BLK'
  2152.       ELSE IF ((I.AND.'04000000) .NE. 0) THEN
  2153.          TYPE = 'RAN'
  2154.       ELSE
  2155.          TYPE = 'UNB'
  2156.       END IF
  2157. C
  2158. C     CURRENT & GRANULE & MAXIMUM SIZES
  2159. C
  2160.       SIZE = DAIB(15)
  2161.       GRAN = DAIB( 4)
  2162.       MAXS = DAIB(16)
  2163. C
  2164. C     ACCESS
  2165. C
  2166.       I = DAIB(7) / 2**12
  2167.       IF ((I.AND.'100) .NE. 0) THEN
  2168.          PREFIX = "P"
  2169.       ELSE
  2170.          PREFIX = "A"
  2171.       END IF
  2172.  
  2173.       RWXD = "-----------"
  2174.       IF ((I.AND.'2000) .NE. 0) THEN                                    SR11/86
  2175.          IF ((I.AND.'0001) .NE. 0) RWXD(10:11) = "OD"                   SR11/86
  2176.          IF ((I.AND.'0002) .NE. 0) RWXD(04:05) = "OW"                   SR11/86
  2177.          IF ((I.AND.'0004) .NE. 0) RWXD(10:11) = 'AD'                   SR11/86
  2178.          IF ((I.AND.'0010) .NE. 0) RWXD(07:08) = 'AX'                   SR11/86
  2179.          IF ((I.AND.'0020) .NE. 0) RWXD(04:05) = 'AW'                   SR11/86
  2180.          IF ((I.AND.'0040) .NE. 0) RWXD(01:02) = 'AR'                   SR11/86
  2181.          IF ((I.AND.'0100) .NE. 0) RWXD(10:11) = 'PD'                   SR11/86
  2182.          IF ((I.AND.'0200) .NE. 0) RWXD(07:08) = 'PX'                   SR11/86
  2183.          IF ((I.AND.'0400) .NE. 0) RWXD(04:05) = 'PW'                   SR11/86
  2184.          IF ((I.AND.'1000) .NE. 0) RWXD(01:02) = 'PR'                   SR11/86
  2185.       ELSE                                                              SR11/86
  2186.          IF ((I.AND.'01) .NE. 0) RWXD(10:11) = "OD"
  2187.          IF ((I.AND.'02) .NE. 0) RWXD(04:05) = "OW"
  2188.          IF ((I.AND.'04) .NE. 0) RWXD(10:11) = PREFIX // 'D'
  2189.          IF ((I.AND.'10) .NE. 0) RWXD(07:08) = PREFIX // 'X'
  2190.          IF ((I.AND.'20) .NE. 0) RWXD(04:05) = PREFIX // 'W'
  2191.          IF ((I.AND.'40) .NE. 0) RWXD(01:02) = PREFIX // 'R'
  2192.       END IF                                                            SR11/86
  2193. C
  2194. C     OWNER
  2195. C
  2196.       IF (PARLS2(1) .NE. DAIB(5) .OR. PARLS2(2) .NE. DAIB(6)) THEN
  2197.          PARLS2(1) = DAIB(5)
  2198.          PARLS2(2) = DAIB(6)
  2199.          PARLS2(3) = 0
  2200.          PARLS2(4) = 0
  2201.          OWNTMP = ' '
  2202. :ASSEM
  2203.         REEN                 MAKE THE ROUTINE RE-ENTRANT
  2204. *
  2205.         TLO   PARLS2         DEFINE PARAMETER LIST
  2206.         NSK
  2207.         BLU   $USERNO        GET USER NAME
  2208. :END
  2209.       END IF
  2210.       OWNER = OWNTMP
  2211. C
  2212. C     DATES AND TIMES
  2213. C
  2214.       ELDATE(1) = DAIB(17)
  2215.       ELDATE(2) = DAIB(18)
  2216.       GEDATE(1) = DAIB(19)
  2217.       GEDATE(2) = DAIB(20)
  2218.       LADATE(1) = DAIB(21)
  2219.       LADATE(2) = DAIB(22)
  2220.       LWDATE(1) = DAIB(23)
  2221.       LWDATE(2) = DAIB(24)
  2222.  
  2223. :ASSEM
  2224.       TMK    ELDATE
  2225.       NSK
  2226.       BLU    $DATE
  2227. *
  2228.       TMK    GEDATE
  2229.       NSK
  2230.       BLU    $DATE
  2231. *
  2232.       TMK    LADATE
  2233.       NSK
  2234.       BLU    $DATE
  2235. *
  2236.       TMK    LWDATE
  2237.       NSK
  2238.       BLU    $DATE
  2239. :END
  2240.  
  2241.       IF (DAIB(17).EQ.'37777777) THEN
  2242.          ELDATE(1) = '   '
  2243.          ELDATE(2) = '   '
  2244.          ELDATE(3) = '   '
  2245.          ELDATE(4) = '   '
  2246.          ELDATE(5) = '   '
  2247.          ELDATE(6) = '   '
  2248.       END IF
  2249.  
  2250.       END
  2251.  
  2252.       SUBROUTINE FILNAM(AREANM,TASCII,ISTAT)
  2253. C
  2254. C CHECK A DISC AREANAME TO INSURE THAT IS CORRECTLY FORMED,
  2255. C AND SET UP THE TRUNCATED ASCII REPRESENTATION WHICH IS USED
  2256. C BY SEVERAL HARRIS SYSTEM SERVICES
  2257. C
  2258. C INPUT:
  2259. C     AREANM -- CHARACTER STRING CONTAINING THE AREANAME TO SCAN
  2260. C
  2261. C OUTPUT:
  2262. C     TASCII -- 4 WORD ARRAY CONTAINING THE COMPLETE AREANAME IN
  2263. C               TRUNCATED ASCII
  2264. C
  2265. C     ISTAT  -- STATUS FLAG RETURNED:
  2266. C                    NEGATIVE IF AREANAME IS MALFORMED
  2267. C                    LENGTH OF INPUT STRING IF SUCCESSFUL
  2268. C
  2269. C WRITTEN 4/83 BY SR
  2270. C
  2271. C ---------------------------------------------------------------------
  2272.  
  2273.       CHARACTER   AREANM*(*)           ! INPUT AREANAME
  2274.       INTEGER     TASCII(4)            ! OUTPUT AREANAME
  2275.       INTEGER     ISTAT                ! STATUS CODE
  2276.  
  2277.       CHARACTER   NAMTMP*18
  2278.       INTEGER     NAMEQV(6)
  2279.       EQUIVALENCE (NAMTMP,NAMEQV)
  2280.  
  2281.       NAMTMP = AREANM                  ! CONVERT AREANAME TO HOLLERITH
  2282.  
  2283. :ASSEM
  2284.         REEN                 MAKE THE ROUTINE RE-ENTRANT
  2285. *
  2286.         TLO   PARLST         INITIALIZE THE SCANNER
  2287.         BLU   $SCINIT
  2288. *
  2289.         TMK   TASCII         IDENTIFY THE OUTPUT BUFFER
  2290.         BLU   $AREANM        CALL AREANAME SERVICE
  2291.         TAM*  ISTAT          GET STATUS RETURNED
  2292. *
  2293.         PORG  *     DATA
  2294. PARLST  DATA  6              INPUT BUFFER LENGTH
  2295.         LAC   NAMTMP         INPUT BUFFER ADDRESS
  2296. :END
  2297.       RETURN
  2298.       END
  2299. C KERMIT PRIMITIVES
  2300. C
  2301. C     SNDPKT   -- SEND PACKET
  2302. C     RESEND   -- RE-SEND PREVIOUS PACKET
  2303. C     SNDACK   -- SEND "ACK" PACKET
  2304. C     SNDNAK   -- SEND "NAK" PACKET
  2305. C     SNDERR   -- SEND ERROR PACKET
  2306. C     RCVPKT   -- RECEIVE PACKET
  2307. C     RCVACK   -- RECEIVE ACK/NAK PACKET
  2308. C     UNPACK   -- DECODE AN INCOMING PACKET
  2309. C     SPAR     -- ENCODE MY SEND/RECEIVE PARAMETERS
  2310. C     RPAR     -- DECODE THE OTHER KERMIT'S SEND/RECEIVE PARAMETERS
  2311. C     PUTDAT   -- FILL PACKET DATA WITH A STRING OF TEXT
  2312. C     ICHKFN   -- COMPUTE PACKET CHECKSUM (INTEGER FUNCTION)
  2313. C     MAKEC    -- MAKE A NUMBER PRINTABLE (INTEGER FUNCTION)
  2314. C     UNCHAR   -- RESTORE A NUMBER FROM PRINTABLE (INTEGER FUNCTION)
  2315. C     ISCTRL   -- IS THIS A CONTROL CHARACTER? (LOGICAL FUNCTION)
  2316. C     CTL      -- CONTROL CHAR TO/FROM PRINTABLE (INTEGER FUNCTION)
  2317. C
  2318. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  2319.  
  2320. C PACKET DESCRIPTION:
  2321. C
  2322. C BYTE 1    -- MARK   : SOH CHARACTER
  2323. C BYTE 2    -- COUNT  : # OF BYTES FOLLOWING THIS FIELD
  2324. C BYTE 3    -- SEQ    : SEQUENCE NUMBER MODULO 64
  2325. C BYTE 4    -- PTYPE  : PACKET TYPE = {D,Y,N,S,B,F,Z,E,...}
  2326. C BYTE 5-   -- DATA   : THE ACTUAL DATA (N BYTES)
  2327. C BYTE N+5  -- CHKSUM : CHECKSUM OF BYTES 2 THROUGH N+4
  2328. C APPENDED: -- EOL    : (NOT CONSIDERED PART OF PACKET PROPER)
  2329.  
  2330.       SUBROUTINE SNDPKT(DATA,NDATA,NSEQ,TYPE)
  2331. C---
  2332. C--- BUILDS AND SENDS PACKET
  2333. C---
  2334.       INTEGER           DATA(*),NDATA,NSEQ
  2335.       CHARACTER         TYPE*1
  2336.  
  2337.       LOGICAL           DEBUG
  2338.       COMMON /DBGCOM/   DEBUG
  2339.       INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  2340.       COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  2341.  
  2342.       INTEGER           ICHKFN,MAKEC
  2343.       INTEGER           PACK(94),NPACK,SOH,I
  2344.       SAVE              PACK,NPACK
  2345.  
  2346.       DATA SOH /1/
  2347.  
  2348.       NPACK = NDATA + 5          ! TOTAL CHARACTERS IN PACKET
  2349.  
  2350.       PACK(1) = SOH              ! MARK (START OF PACKET CHARACTER)
  2351.       PACK(2) = MAKEC(NDATA+3)   ! COUNT = SEQ+PTYPE+DATA+CHKSUM
  2352.       PACK(3) = MAKEC(NSEQ)      ! SEQUENCE NUMBER
  2353.       PACK(4) = ICHAR(TYPE)      ! PACKET TYPE
  2354.       FOR I=1,NDATA
  2355.          PACK(I+4) = DATA(I)     ! DATA
  2356.       END FOR
  2357.       PACK(NDATA+5) = ICHKFN(PACK,NPACK)     ! CHECKSUM
  2358.  
  2359.       IF (DEBUG) THEN
  2360.          IF (NDATA .LE. 0) THEN
  2361.             WRITE (*,1100) NSEQ, TYPE, NPACK, NDATA
  2362.          ELSE
  2363.             WRITE (*,1100) NSEQ, TYPE, NPACK, NDATA,
  2364.      +         ICHAR('<'), (DATA(I), I=1,NDATA), ICHAR('>')
  2365.          END IF
  2366.  1100    FORMAT (' SENT',I3,') TYPE=',A,' SIZE=',I3,' NDATA=',I3,
  2367.      +      :,2X,R1,89R1,R1)
  2368.       END IF
  2369.       GO TO 100
  2370.  
  2371. C---
  2372. C--- RE-SENDS PREVIOUS PACKET
  2373. C---
  2374.       ENTRY RESEND()
  2375.  
  2376.       IF (DEBUG) WRITE (*,*) 'RE-SENDING LAST PACKET'
  2377.  
  2378. C     SEND PADDING IF THEY REQUESTED IT
  2379. 100   FOR I=1,NSPAD
  2380.          CALL PUT1CW(NSPCHR,1)
  2381.       END FOR
  2382.  
  2383. C     SEND PACKET
  2384.       CALL PUT1CW(PACK,NPACK)
  2385.       END
  2386.  
  2387.       SUBROUTINE SNDACK(DATA,NDATA,NSEQ)
  2388. C---
  2389. C--- SEND ACK PACKET
  2390. C---
  2391.       INTEGER           DATA(*),NDATA,NSEQ
  2392.  
  2393.       CALL SNDPKT(DATA,NDATA,NSEQ,'Y')
  2394.       END
  2395.  
  2396.       SUBROUTINE SNDNAK(NSEQ)
  2397. C---
  2398. C--- SEND NAK PACKET
  2399. C---
  2400.       INTEGER           NSEQ
  2401.       INTEGER           DATA(1),NDATA
  2402.  
  2403.       NDATA = 0
  2404.       CALL SNDPKT(DATA,NDATA,NSEQ,'N')
  2405.       END
  2406.  
  2407.       SUBROUTINE SNDERR(MSG,MXDATA,DATA,NSEQ)
  2408. C---
  2409. C--- SEND ERROR PACKET
  2410. C---
  2411.       CHARACTER         MSG*(*)
  2412.       INTEGER           MXDATA,DATA(*),NSEQ
  2413.  
  2414.       LOGICAL           DEBUG
  2415.       COMMON /DBGCOM/   DEBUG
  2416.  
  2417.       INTEGER           NDATA,PREFIX
  2418.  
  2419.       IF (DEBUG) WRITE (*,*) MSG
  2420.  
  2421. C     COPY MESSAGE INTO DATA ARRAY
  2422.       PREFIX = 1
  2423.       CALL PUTDAT(MSG,PREFIX,MXDATA,DATA,NDATA)
  2424.  
  2425. C     SEND "E" PACKET
  2426.       CALL SNDPKT(DATA,NDATA,NSEQ,'E')
  2427.       END
  2428.  
  2429.       SUBROUTINE RCVPKT(MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
  2430. C---
  2431. C--- RECEIVES PACKET
  2432. C---
  2433.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT
  2434.       CHARACTER         TYPE*1
  2435.  
  2436.       LOGICAL           DEBUG
  2437.       COMMON /DBGCOM/   DEBUG
  2438.       INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  2439.       COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  2440.  
  2441.       INTEGER           MXBUF
  2442.       PARAMETER (MXBUF=80)
  2443.       INTEGER           PACK(MXBUF)
  2444.  
  2445.       INTEGER           I
  2446.  
  2447. C     READ PACKET
  2448.  
  2449.       CALL PUT1CW(NSEOL,1)
  2450.  
  2451.       READ (3,'(100R1)',IOSTAT=ISTAT) PACK
  2452.       IF (ISTAT .NE. 0) THEN
  2453.          IF (DEBUG) WRITE (*,*) 'I/O ERROR ON READ, IOSTAT=', ISTAT
  2454.          GO TO 800
  2455.       END IF
  2456.  
  2457. C     CHECK
  2458.  
  2459.       CALL UNPACK(PACK,MXBUF,MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
  2460.       IF (ISTAT .NE. 0) THEN
  2461.          IF (DEBUG) WRITE (*,*) 'INVALID PACKET RECEIVED'
  2462.          GO TO 800
  2463.       END IF
  2464.       GO TO 900
  2465.  
  2466. 800   ISTAT = -1  ! UNSUCCESSFUL
  2467.       RETURN
  2468.  
  2469. 900   ISTAT = 0   ! SUCCESSFUL
  2470.       RETURN
  2471.       END
  2472.  
  2473.       SUBROUTINE RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT)
  2474. C---
  2475. C--- RECEIVE "ACK" PACKET AND CHECK VALIDITY
  2476. C---
  2477.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT
  2478.  
  2479.       LOGICAL           DEBUG
  2480.       COMMON /DBGCOM/   DEBUG
  2481.  
  2482.       INTEGER           RSEQ
  2483.       CHARACTER         TYPE*1
  2484.  
  2485.       CALL RCVPKT(MXDATA,DATA,NDATA,RSEQ,TYPE,ISTAT)
  2486.       IF (ISTAT .NE. 0) GO TO 810
  2487.  
  2488.       IF (TYPE .EQ. 'Y' .AND. NSEQ .EQ. RSEQ) GO TO 900
  2489.       IF (TYPE .EQ. 'N') THEN
  2490.          IF (MOD(NSEQ+1,64) .EQ. RSEQ) THEN
  2491.             IF (DEBUG) WRITE (*,*) '(EQUIVALENT TO ACK)'
  2492.             GO TO 900
  2493.          END IF
  2494.          GO TO 810
  2495.       END IF
  2496.  
  2497. CCC      IF (TYPE .EQ. 'E') GO TO 800
  2498. CCC      GO TO 810
  2499.  
  2500. 800   ISTAT = -1  ! ERROR PACKET
  2501.       RETURN
  2502.  
  2503. 810   ISTAT = 1   ! UNSUCCESSFUL
  2504.       IF (DEBUG) WRITE (*,*) 'RECEIVED NAK OR EQUIVALENT'
  2505.       RETURN
  2506.  
  2507. 900   ISTAT = 0   ! SUCCESSFUL
  2508.       RETURN
  2509.       END
  2510.  
  2511.       SUBROUTINE UNPACK(PACK,MXBUF,MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT)
  2512. C---
  2513. C--- UNPACK AND VALIDATE PACKET (CALLED BY RCVPKT)
  2514. C---
  2515.       INTEGER           PACK(*),MXBUF
  2516.       INTEGER           MXDATA,DATA(*),NDATA,NSEQ,ISTAT
  2517.       CHARACTER         TYPE*1
  2518.  
  2519.       LOGICAL           DEBUG
  2520.       COMMON /DBGCOM/   DEBUG
  2521.  
  2522.       INTEGER           UNCHAR,ICHKFN
  2523.       INTEGER           NPACK,IPACK,NSOH,CHKSUM,CHKSU2,NCHARS,SOH,I
  2524.  
  2525.       DATA SOH /1/
  2526.  
  2527. C     INITIALIZE
  2528.  
  2529.       NSOH   = 0
  2530.       TYPE  = '?'
  2531.  
  2532. C     MARK FIELD : SOH CHARACTER
  2533.  
  2534.       IPACK = 0
  2535.       FOR I=1,MXBUF-3
  2536.          IPACK = IPACK + 1
  2537.          IF (PACK(IPACK) .EQ. SOH) GO TO 100
  2538.       END FOR
  2539.       IF (DEBUG) WRITE (*,*) 'UNPACK: SOH NOT FOUND'
  2540.       GO TO 800
  2541.  
  2542. 100   NSOH = IPACK
  2543.       IF (DEBUG .AND. NSOH .NE. 1) WRITE (*,*) 'SOH FOUND AT', NSOH
  2544.  
  2545. C     COUNT FIELD : # OF BYTES FOLLOWING THIS FIELD
  2546.  
  2547.       IPACK = IPACK + 1
  2548.       NPACK = UNCHAR( PACK(IPACK) )
  2549.       IF (NPACK .LT. 3 .OR. NPACK+2 .GT. MXBUF) THEN
  2550.          IF (DEBUG) WRITE (*,*) 'UNPACK: INVALID COUNT FIELD', NPACK
  2551.          GO TO 800
  2552.       ELSE IF (NPACK+NSOH+1 .GT. MXBUF) THEN
  2553.          IF (DEBUG) WRITE (*,*) 'UNPACK: BUFFER OVERRUN', NPACK+NSOH+1
  2554.          GO TO 800
  2555.       END IF
  2556.       NPACK = NPACK + 2
  2557.  
  2558. C     SEQ FIELD : SEQUENCE NUMBER MODULO 64
  2559.  
  2560.       IPACK = IPACK + 1
  2561.       NSEQ = UNCHAR( PACK(IPACK) )
  2562.       IF (NSEQ .LT. 0 .OR. NSEQ .GT. 63) THEN
  2563.          IF (DEBUG) WRITE (*,*) 'UNPACK: INVALID SEQ FIELD', NSEQ
  2564.          GO TO 800
  2565.       END IF
  2566.  
  2567. C     PTYPE FIELD : PACKET TYPE = {D,Y,N,S,B,F,Z,E,...}
  2568.  
  2569.       IPACK = IPACK + 1
  2570.       TYPE = CHAR( PACK(IPACK) )
  2571.       IF (TYPE .LT. 'A' .OR. TYPE .GT. 'Z') THEN
  2572.          IF (DEBUG) WRITE (*,*) 'UNPACK: INVALID PACKET TYPE ', TYPE
  2573.          GO TO 800
  2574.       END IF
  2575.  
  2576. C     DATA FIELD : COPY INTO DATA ARRAY
  2577.  
  2578.       NDATA = NPACK-5
  2579.       IF (NDATA .GT. MXDATA) THEN
  2580.          IF (DEBUG) WRITE (*,*) 'UNPACK: MORE DATA RECEIVED THAN',
  2581.      +      ' EXPECTED (N=', NDATA, ' MAX=', MXDATA, ')'
  2582.          NDATA = MXDATA
  2583.       END IF
  2584.       FOR I=1,NDATA
  2585.          DATA(I) = PACK(I+NSOH+3)
  2586.       END FOR
  2587.  
  2588. C     CHKSUM FIELD : CHECKSUM OF BYTES 2 THROUGH N-4
  2589.  
  2590.       CHKSUM = PACK(NPACK+NSOH-1)
  2591.       CHKSU2 = ICHKFN( PACK(NSOH), NPACK )
  2592.       IF (CHKSUM .NE. CHKSU2) THEN
  2593.          IF (DEBUG) WRITE (*,*) 'UNPACK: CHECKSUMS=', CHKSUM,CHKSU2
  2594.          GO TO 800
  2595.       END IF
  2596.  
  2597. C     LOG ERROR MESSAGES
  2598.  
  2599.       IF (TYPE .EQ. 'E') THEN
  2600.          IF (DEBUG) THEN
  2601.             WRITE (*,*) 'ERROR PACKET RECEIVED:'
  2602.             WRITE (*,*) '***', (CHAR(PACK(I)), I=NSOH+4,NPACK-1), '***'
  2603.          END IF
  2604.       END IF
  2605.       GO TO 900
  2606.  
  2607. 800   ISTAT = -1  ! UNSUCCESSFUL
  2608.       IF (DEBUG) THEN
  2609.          NCHARS = 0
  2610.          FOR I=MXBUF,1,-1
  2611.             IF (PACK(I) .NE. ICHAR(' ') ) THEN
  2612.                NCHARS = I
  2613.                EXIT FOR
  2614.             END IF
  2615.          END FOR
  2616.          WRITE (*,*) 'DUMP OF PACKET CONTENTS:'
  2617.          WRITE (*,'(26(2X,R1))') (MAX(ICHAR(' '),PACK(I)), I=1,NCHARS)
  2618.          WRITE (*,'(1X,26I3)') (PACK(I), I=1,NCHARS)
  2619.       END IF
  2620.       RETURN
  2621.  
  2622. 900   ISTAT = 0 ! SUCCESSFUL
  2623.       IF (DEBUG) THEN
  2624.          IF (NDATA .LE. 0) THEN
  2625.             WRITE (*,1900) NSEQ, TYPE, NPACK, NDATA
  2626.          ELSE
  2627.             WRITE (*,1900) NSEQ, TYPE, NPACK, NDATA,
  2628.      +         ICHAR('<'), (DATA(I), I=1,NDATA), ICHAR('>')
  2629.          END IF
  2630.  1900    FORMAT (' RCVD',I3,') TYPE=',A,' SIZE=',I3,' NDATA=',I3,
  2631.      +      :,2X,93R1)
  2632.       END IF
  2633.       END
  2634.  
  2635.       SUBROUTINE SPAR(MXDATA,DATA,NDATA)
  2636. C---
  2637. C--- FILL THE DATA ARRAY WITH MY SEND-INIT PARAMETERS
  2638. C---
  2639.       INTEGER           MXDATA,DATA(*),NDATA
  2640.  
  2641.       LOGICAL           DEBUG
  2642.       COMMON /DBGCOM/   DEBUG
  2643.       INTEGER           MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
  2644.       COMMON /RCVCOM/   MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME
  2645.  
  2646.       INTEGER           MAKEC,CTL
  2647.       LOGICAL           FIRST
  2648.  
  2649.       DATA FIRST /.TRUE./
  2650.  
  2651.       NDATA = 6
  2652.       IF (MXDATA .LT. NDATA) THEN
  2653.          WRITE (*,*) 'FATAL ERROR: DATA ARRAY < MIN SIZE IN "SPAR"'
  2654.          STOP
  2655.       END IF
  2656.  
  2657.       DATA(1) = MAKEC( MRPSIZ )     ! BIGGEST PACKET I CAN RECEIVE
  2658.       DATA(2) = MAKEC( MYTIME )     ! WHEN I WANT TIMEOUT
  2659.       DATA(3) = MAKEC( MYPAD )      ! HOW MUCH PADDING TO SEND ME
  2660.       DATA(4) = CTL( MYPCHR )       ! PAD CHARACTER TO USE
  2661.       DATA(5) = MAKEC( MYEOL )      ! EOL TO SEND ME
  2662.       DATA(6) = MYQUOT              ! CONTROL QUOTE CHAR I WILL SEND
  2663. C     USE DEFAULTS FOR THE FOLLOWING:
  2664. C     7. NEITHER OF US WILL DO 8-BIT QUOTING
  2665. C     8. BOTH OF US WILL USE A SINGLE CHARACTER CHECKSUM
  2666. C     9. NEITHER OF US WILL USE REPEAT PREFIXES
  2667.  
  2668.       IF (DEBUG .AND. FIRST) THEN
  2669.          FIRST = .FALSE.
  2670.          WRITE (*,*)
  2671.          WRITE (*,*) 'HARRIS KERMIT REQUESTS THE FOLLOWING FROM LOCAL:'
  2672.          WRITE (*,*)
  2673.          WRITE (*,*) 'BIGGEST PACKET I CAN RECEIVE IS', MRPSIZ,' CHARS'
  2674.          WRITE (*,*) 'SUGGEST THEY TIMEOUT AFTER', MYTIME, ' SECONDS'
  2675.          WRITE (*,*) 'PREFIX PACKETS WITH', MYPAD, ' PAD CHARS',
  2676.      +      ', USING CHARACTER', MYPCHR
  2677.          WRITE (*,*) 'TERMINATE PACKETS WITH CHARACTER', MYEOL
  2678.          WRITE (*,*) 'I WILL SEND "', CHAR(MYQUOT),
  2679.      +      '" TO QUOTE CONTROL CHARACTERS'
  2680.          WRITE (*,*) '(USE DEFAULTS FOR THE REMAINDER)'
  2681.          WRITE (*,*)
  2682.       END IF
  2683.       END
  2684.  
  2685.       SUBROUTINE RPAR(DATA,NDATA)
  2686. C---
  2687. C--- GET THE OTHER HOST'S SEND-INIT PARAMETERS
  2688. C---
  2689.       INTEGER           DATA(*),NDATA
  2690.  
  2691.       LOGICAL           DEBUG
  2692.       COMMON /DBGCOM/   DEBUG
  2693.       INTEGER           MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  2694.       COMMON /SNDCOM/   MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME
  2695.  
  2696.       INTEGER           UNCHAR,CTL
  2697.       INTEGER           I
  2698.       LOGICAL           FIRST
  2699.  
  2700.       DATA FIRST /.TRUE./
  2701.  
  2702. C     READ THEIR PACKET
  2703.  
  2704.       IF (NDATA .LT. 1) GO TO 200
  2705.       I      = UNCHAR( DATA(1) )    ! BIGGEST PACKET THEY CAN RECEIVE
  2706.       IF (I .GT. 0 .AND. I .LT. MSPSIZ) MSPSIZ = I
  2707.  
  2708.       IF (NDATA .LT. 2) GO TO 200
  2709.       NSTIME = UNCHAR( DATA(2) )    ! WHEN THEY WANT TIMEOUT
  2710.  
  2711.       IF (NDATA .LT. 3) GO TO 200
  2712.       NSPAD  = UNCHAR( DATA(3) )    ! HOW MUCH PADDING TO SEND THEM
  2713.  
  2714.       IF (NDATA .LT. 4) GO TO 200
  2715.       NSPCHR = CTL( DATA(4) )       ! PAD CHARACTER TO USE
  2716.  
  2717.       IF (NDATA .LT. 5) GO TO 200
  2718.       I      = UNCHAR( DATA(5) )    ! EOL TO SEND THEM
  2719.       IF (I .GT. 0) NSEOL = I
  2720.  
  2721.       IF (NDATA .LT. 6) GO TO 200
  2722.       I      = DATA(6)              ! INCOMING DATA QUOTE CHARACTER
  2723.       IF (I .GT. 0) NSQUOT = I
  2724.  
  2725. 200   IF (DEBUG .AND. FIRST) THEN
  2726.          FIRST = .FALSE.
  2727.          WRITE (*,*)
  2728.          WRITE (*,*) 'REQUESTED OF HARRIS KERMIT BY LOCAL:'
  2729.          WRITE (*,*)
  2730.          WRITE (*,*) 'BIGGEST PACKET TO SEND THEM IS', MSPSIZ, ' CHARS'
  2731.          WRITE (*,*) 'SUGGEST I TIMEOUT AFTER', NSTIME, ' SECONDS'
  2732.          WRITE (*,*) 'PREFIX PACKETS WITH', NSPAD, ' PAD CHARS',
  2733.      +      ', USING CHARACTER', NSPCHR
  2734.          WRITE (*,*) 'TERMINATE PACKETS WITH CHARACTER', NSEOL
  2735.          WRITE (*,*) 'THEY WILL SEND "', CHAR(NSQUOT),
  2736.      +      '" TO QUOTE CONTROL CHARACTERS'
  2737.          WRITE (*,*) '(USING DEFAULTS FOR THE REMAINDER, REGARDLESS)'
  2738.          WRITE (*,*)
  2739.       END IF
  2740.       END
  2741.  
  2742.       SUBROUTINE PUTDAT(MSG,PREFIX,MXDATA,DATA,NDATA)
  2743. C---
  2744. C--- FILL PACKET DATA WITH SPECIFIED CHARACTER STRING
  2745. C---
  2746. C--- <PREFIX> NON-ZERO PREFIXES MESSAGE WITH "HARRIS:" IDENTIFIER
  2747. C---
  2748.       CHARACTER         MSG*(*)
  2749.       INTEGER           PREFIX,MXDATA,DATA(*),NDATA
  2750.  
  2751.       INTEGER           N,C,I
  2752.  
  2753.       CHARACTER         PRE*8
  2754.       DATA PRE /'HARRIS: '/
  2755.  
  2756. C     COPY PREFIX INTO DATA ARRAY IF REQUESTED
  2757.       NDATA = 0
  2758.       IF (PREFIX .NE. 0) THEN
  2759.          FOR I=1,LEN(PRE)
  2760.             EXIT FOR IF (NDATA .GE. MXDATA)
  2761.             NDATA = NDATA + 1
  2762.             DATA(NDATA) = ICHAR( PRE(I:I) )
  2763.          END FOR
  2764.       END IF
  2765.  
  2766. C     COPY MESSAGE INTO DATA ARRAY, WITHOUT TRAILING BLANKS
  2767.  
  2768.       N = NDATA
  2769.       FOR I=1,LEN(MSG)
  2770.          EXIT FOR IF (N .GE. MXDATA)
  2771.          C =  ICHAR( MSG(I:I) )
  2772.          N = N + 1
  2773.          IF (C .NE. ICHAR(' ') ) NDATA = N
  2774.          DATA(N) = C
  2775.       END FOR
  2776.       END
  2777.  
  2778.       INTEGER FUNCTION ICHKFN(PACK,NPACK)
  2779. C---
  2780. C--- CALCULATE CHECKSUM AND CONVERT TO PRINTABLE FORM
  2781. C---
  2782.       INTEGER           PACK(*),NPACK
  2783.  
  2784.       INTEGER           MAKEC
  2785.       INTEGER           S,CHKSUM,I
  2786.  
  2787.       S = 0
  2788.       FOR I=2,NPACK-1
  2789.          S = S + PACK(I)
  2790.       END FOR
  2791.  
  2792. C     CHECKSUM = LOW ORDER 6 BITS OF THE RESULT OF THE FUNCTION:
  2793. C        S(BITS 0:5) + S(BITS 6:7)
  2794. C     WHERE S IS THE SUM OF ALL CHARACTERS IN THIS PACKET
  2795.  
  2796.       CHKSUM = (S + ((S .AND. '300)/'100)) .AND. '77
  2797.       ICHKFN = MAKEC(CHKSUM)
  2798.       END
  2799.  
  2800.       INTEGER FUNCTION MAKEC(ICHR)
  2801. C---
  2802. C--- CONVERT A NUMBER TO A PRINTABLE CHARACTER
  2803. C---
  2804.       INTEGER           ICHR
  2805.  
  2806.       MAKEC = ICHR + 32
  2807.       END
  2808.  
  2809.       INTEGER FUNCTION UNCHAR(ICHR)
  2810. C---
  2811. C--- RESTORE A NUMBER FROM A CHARACTER (REVERSE OF "MAKEC")
  2812. C---
  2813.       INTEGER           ICHR
  2814.  
  2815.       UNCHAR = ICHR - 32
  2816.       END
  2817.  
  2818.       LOGICAL FUNCTION ISCTRL(ICHR)
  2819. C---
  2820. C--- RETURN TRUE IF SPECIFIED CHARACTER A CONTROL CHARACTER
  2821. C---
  2822.       INTEGER           ICHR
  2823.  
  2824.       ISCTRL = (ICHR .LT. 32 .OR. ICHR .EQ. 127)
  2825.       END
  2826.  
  2827.       INTEGER FUNCTION CTL(ICHR)
  2828. C---
  2829. C--- TOGGLE A CHARACTER BETWEEN CONTROL AND PRINTABLE REPRESENTATIONS
  2830. C---
  2831.       INTEGER           ICHR
  2832.  
  2833.       CTL = ICHR .XOR. 64
  2834.       END
  2835.